TTG3 Combined Step 1 and 3 for Trees That Grow
[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, 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 noExt 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 noExt 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 noExt hasParen unqualSplice e)
356
357 mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
358 mkHsSpliceTy hasParen e = HsSpliceTy noExt
359 (HsUntypedSplice noExt hasParen unqualSplice e)
360
361 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
362 mkHsQuasiQuote quoter span quote
363 = HsQuasiQuote noExt unqualSplice quoter span quote
364
365 unqualQuasiQuote :: RdrName
366 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
367 -- A name (uniquified later) to
368 -- identify the quasi-quote
369
370 mkHsString :: SourceTextX p => String -> HsLit p
371 mkHsString s = HsString noSourceText (mkFastString s)
372
373 mkHsStringPrimLit :: SourceTextX p => FastString -> HsLit p
374 mkHsStringPrimLit fs
375 = HsStringPrim noSourceText (fastStringToByteString fs)
376
377 -------------
378 userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
379 -> [LHsTyVarBndr (GhcPass p)]
380 -- Caller sets location
381 userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ]
382
383 userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
384 -- Caller sets location
385 userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v))
386 | v <- bndrs ]
387
388
389 {-
390 ************************************************************************
391 * *
392 Constructing syntax with no location info
393 * *
394 ************************************************************************
395 -}
396
397 nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
398 nlHsVar n = noLoc (HsVar noExt (noLoc n))
399
400 -- NB: Only for LHsExpr **Id**
401 nlHsDataCon :: DataCon -> LHsExpr GhcTc
402 nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con))
403
404 nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
405 nlHsLit n = noLoc (HsLit noExt n)
406
407 nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
408 nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n)))
409
410 nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
411 nlVarPat n = noLoc (VarPat noExt (noLoc n))
412
413 nlLitPat :: HsLit GhcPs -> LPat GhcPs
414 nlLitPat l = noLoc (LitPat noExt l)
415
416 nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
417 nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x))
418
419 nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
420 -> LHsExpr (GhcPass id)
421 nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
422 , syn_arg_wraps = arg_wraps
423 , syn_res_wrap = res_wrap }) args
424 | [] <- arg_wraps -- in the noSyntaxExpr case
425 = ASSERT( isIdHsWrapper res_wrap )
426 foldl nlHsApp (noLoc fun) args
427
428 | otherwise
429 = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
430 mkLHsWrap arg_wraps args))
431
432 nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
433 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
434
435 nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
436 nlHsVarApps f xs = noLoc (foldl mk (HsVar noExt (noLoc f))
437 (map ((HsVar noExt) . noLoc) xs))
438 where
439 mk f a = HsApp noExt (noLoc f) (noLoc a)
440
441 nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
442 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
443
444 nlConVarPatName :: Name -> [Name] -> LPat GhcRn
445 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
446
447 nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id
448 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
449
450 nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
451 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
452
453 nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
454 nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
455
456 nlNullaryConPat :: IdP id -> LPat id
457 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
458
459 nlWildConPat :: DataCon -> LPat GhcPs
460 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
461 (PrefixCon (nOfThem (dataConSourceArity con)
462 nlWildPat)))
463
464 nlWildPat :: LPat GhcPs
465 nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking
466
467 nlWildPatName :: LPat GhcRn
468 nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking
469
470 nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
471 -> LHsExpr GhcPs
472 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
473
474 nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
475 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
476
477 nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
478 nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
479 nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
480 -> LHsExpr (GhcPass id)
481 nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
482 -> LHsExpr GhcPs
483 nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
484
485 nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match]))
486 nlHsPar e = noLoc (HsPar noExt e)
487
488 -- Note [Rebindable nlHsIf]
489 -- nlHsIf should generate if-expressions which are NOT subject to
490 -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
491 nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false)
492
493 nlHsCase expr matches
494 = noLoc (HsCase noExt expr (mkMatchGroup Generated matches))
495 nlList exprs = noLoc (ExplicitList noExt Nothing exprs)
496
497 nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
498 nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
499 nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
500 nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
501
502 nlHsAppTy f t = noLoc (HsAppTy noExt f t)
503 nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x))
504 nlHsFunTy a b = noLoc (HsFunTy noExt a b)
505 nlHsParTy t = noLoc (HsParTy noExt t)
506
507 nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
508 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
509
510 {-
511 Tuples. All these functions are *pre-typechecker* because they lack
512 types on the tuple.
513 -}
514
515 mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
516 -- Makes a pre-typechecker boxed tuple, deals with 1 case
517 mkLHsTupleExpr [e] = e
518 mkLHsTupleExpr es
519 = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed
520
521 mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
522 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
523
524 nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
525 nlTuplePat pats box = noLoc (TuplePat noExt pats box)
526
527 missingTupArg :: HsTupArg GhcPs
528 missingTupArg = Missing noExt
529
530 mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
531 mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed
532 mkLHsPatTup [lpat] = lpat
533 mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed
534
535 -- The Big equivalents for the source tuple expressions
536 mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
537 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
538
539 mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
540 mkBigLHsTup = mkChunkified mkLHsTupleExpr
541
542 -- The Big equivalents for the source tuple patterns
543 mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
544 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
545
546 mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
547 mkBigLHsPatTup = mkChunkified mkLHsPatTup
548
549 -- $big_tuples
550 -- #big_tuples#
551 --
552 -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
553 -- we might concievably want to build such a massive tuple as part of the
554 -- output of a desugaring stage (notably that for list comprehensions).
555 --
556 -- We call tuples above this size \"big tuples\", and emulate them by
557 -- creating and pattern matching on >nested< tuples that are expressible
558 -- by GHC.
559 --
560 -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
561 -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
562 -- construction to be big.
563 --
564 -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
565 -- and 'mkTupleCase' functions to do all your work with tuples you should be
566 -- fine, and not have to worry about the arity limitation at all.
567
568 -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
569 mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
570 -> [a] -- ^ Possible \"big\" list of things to construct from
571 -> a -- ^ Constructed thing made possible by recursive decomposition
572 mkChunkified small_tuple as = mk_big_tuple (chunkify as)
573 where
574 -- Each sub-list is short enough to fit in a tuple
575 mk_big_tuple [as] = small_tuple as
576 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
577
578 chunkify :: [a] -> [[a]]
579 -- ^ Split a list into lists that are small enough to have a corresponding
580 -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
581 -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
582 chunkify xs
583 | n_xs <= mAX_TUPLE_SIZE = [xs]
584 | otherwise = split xs
585 where
586 n_xs = length xs
587 split [] = []
588 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
589
590 {-
591 ************************************************************************
592 * *
593 LHsSigType and LHsSigWcType
594 * *
595 ********************************************************************* -}
596
597 mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
598 mkLHsSigType ty = mkHsImplicitBndrs ty
599
600 mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
601 mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
602
603 mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
604 -> [LSig GhcRn]
605 -> NameEnv a
606 mkHsSigEnv get_info sigs
607 = mkNameEnv (mk_pairs ordinary_sigs)
608 `extendNameEnvList` (mk_pairs gen_dm_sigs)
609 -- The subtlety is this: in a class decl with a
610 -- default-method signature as well as a method signature
611 -- we want the latter to win (Trac #12533)
612 -- class C x where
613 -- op :: forall a . x a -> x a
614 -- default op :: forall b . x b -> x b
615 -- op x = ...(e :: b -> b)...
616 -- The scoped type variables of the 'default op', namely 'b',
617 -- scope over the code for op. The 'forall a' does not!
618 -- This applies both in the renamer and typechecker, both
619 -- of which use this function
620 where
621 (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
622 is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True
623 is_gen_dm_sig _ = False
624
625 mk_pairs :: [LSig GhcRn] -> [(Name, a)]
626 mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
627 , L _ n <- ns ]
628
629 mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
630 -- Convert TypeSig to ClassOpSig
631 -- The former is what is parsed, but the latter is
632 -- what we need in class/instance declarations
633 mkClassOpSigs sigs
634 = map fiddle sigs
635 where
636 fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
637 fiddle sig = sig
638
639 typeToLHsType :: Type -> LHsType GhcPs
640 -- ^ Converting a Type to an HsType RdrName
641 -- This is needed to implement GeneralizedNewtypeDeriving.
642 --
643 -- Note that we use 'getRdrName' extensively, which
644 -- generates Exact RdrNames rather than strings.
645 typeToLHsType ty
646 = go ty
647 where
648 go :: Type -> LHsType GhcPs
649 go ty@(FunTy arg _)
650 | isPredTy arg
651 , (theta, tau) <- tcSplitPhiTy ty
652 = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
653 , hst_xqual = noExt
654 , hst_body = go tau })
655 go (FunTy arg res) = nlHsFunTy (go arg) (go res)
656 go ty@(ForAllTy {})
657 | (tvs, tau) <- tcSplitForAllTys ty
658 = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
659 , hst_xforall = noExt
660 , hst_body = go tau })
661 go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
662 go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
663 go (LitTy (NumTyLit n)) = noLoc $ HsTyLit noExt (HsNumTy noSourceText n)
664 go (LitTy (StrTyLit s)) = noLoc $ HsTyLit noExt (HsStrTy noSourceText s)
665 go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args')
666 where
667 args' = filterOutInvisibleTypes tc args
668 go (CastTy ty _) = go ty
669 go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co)
670
671 -- Source-language types have _invisible_ kind arguments,
672 -- so we must remove them here (Trac #8563)
673
674 go_tv :: TyVar -> LHsTyVarBndr GhcPs
675 go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
676 (go (tyVarKind tv))
677
678
679 {- *********************************************************************
680 * *
681 --------- HsWrappers: type args, dict args, casts ---------
682 * *
683 ********************************************************************* -}
684
685 mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
686 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
687
688 -- Avoid (HsWrap co (HsWrap co' _)).
689 -- See Note [Detecting forced eta expansion] in DsExpr
690 mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
691 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
692 mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
693 mkHsWrap co_fn e = HsWrap noExt co_fn e
694
695 mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
696 -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
697 mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
698
699 mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
700 -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
701 mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
702
703 mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
704 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
705
706 mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
707 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
708 | otherwise = HsCmdWrap noExt w cmd
709
710 mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
711 mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
712
713 mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
714 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
715 | otherwise = CoPat noExt co_fn p ty
716
717 mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
718 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
719 | otherwise = CoPat noExt (mkWpCastN co) pat ty
720
721 mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
722 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
723
724 {-
725 l
726 ************************************************************************
727 * *
728 Bindings; with a location at the top
729 * *
730 ************************************************************************
731 -}
732
733 mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
734 -> HsBind GhcPs
735 -- Not infix, with place holders for coercion and free vars
736 mkFunBind fn ms = FunBind { fun_id = fn
737 , fun_matches = mkMatchGroup Generated ms
738 , fun_co_fn = idHsWrapper
739 , bind_fvs = placeHolderNames
740 , fun_tick = [] }
741
742 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
743 -> HsBind GhcRn
744 -- In Name-land, with empty bind_fvs
745 mkTopFunBind origin fn ms = FunBind { fun_id = fn
746 , fun_matches = mkMatchGroup origin ms
747 , fun_co_fn = idHsWrapper
748 , bind_fvs = emptyNameSet -- NB: closed
749 -- binding
750 , fun_tick = [] }
751
752 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
753 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
754
755 mkVarBind :: IdP p -> LHsExpr p -> LHsBind p
756 mkVarBind var rhs = L (getLoc rhs) $
757 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
758
759 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
760 -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
761 mkPatSynBind name details lpat dir = PatSynBind psb
762 where
763 psb = PSB{ psb_id = name
764 , psb_args = details
765 , psb_def = lpat
766 , psb_dir = dir
767 , psb_fvs = placeHolderNames }
768
769 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
770 -- considered infix.
771 isInfixFunBind :: HsBindLR id1 id2 -> Bool
772 isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
773 = any (isInfixMatch . unLoc) (unLoc matches)
774 isInfixFunBind _ = False
775
776
777 ------------
778 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
779 -> LHsExpr GhcPs -> LHsBind GhcPs
780 mk_easy_FunBind loc fun pats expr
781 = L loc $ mkFunBind (L loc fun)
782 [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
783 (noLoc emptyLocalBinds)]
784
785 -- | Make a prefix, non-strict function 'HsMatchContext'
786 mkPrefixFunRhs :: Located id -> HsMatchContext id
787 mkPrefixFunRhs n = FunRhs { mc_fun = n
788 , mc_fixity = Prefix
789 , mc_strictness = NoSrcStrict }
790
791 ------------
792 mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
793 -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
794 -> Located (HsLocalBinds (GhcPass p))
795 -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
796 mkMatch ctxt pats expr lbinds
797 = noLoc (Match { m_ctxt = ctxt
798 , m_pats = map paren pats
799 , m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds })
800 where
801 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat noExt lp)
802 | otherwise = lp
803
804 {-
805 ************************************************************************
806 * *
807 Collecting binders
808 * *
809 ************************************************************************
810
811 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
812
813 ...
814 where
815 (x, y) = ...
816 f i j = ...
817 [a, b] = ...
818
819 it should return [x, y, f, a, b] (remember, order important).
820
821 Note [Collect binders only after renaming]
822 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
823 These functions should only be used on HsSyn *after* the renamer,
824 to return a [Name] or [Id]. Before renaming the record punning
825 and wild-card mechanism makes it hard to know what is bound.
826 So these functions should not be applied to (HsSyn RdrName)
827
828 Note [Unlifted id check in isUnliftedHsBind]
829 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
830 The function isUnliftedHsBind is used to complain if we make a top-level
831 binding for a variable of unlifted type.
832
833 Such a binding is illegal if the top-level binding would be unlifted;
834 but also if the local letrec generated by desugaring AbsBinds would be.
835 E.g.
836 f :: Num a => (# a, a #)
837 g :: Num a => a -> a
838 f = ...g...
839 g = ...g...
840
841 The top-level bindings for f,g are not unlifted (because of the Num a =>),
842 but the local, recursive, monomorphic bindings are:
843
844 t = /\a \(d:Num a).
845 letrec fm :: (# a, a #) = ...g...
846 gm :: a -> a = ...f...
847 in (fm, gm)
848
849 Here the binding for 'fm' is illegal. So generally we check the abe_mono types.
850
851 BUT we have a special case when abs_sig is true;
852 see HsBinds Note [The abs_sig field of AbsBinds]
853 -}
854
855 ----------------- Bindings --------------------------
856
857 -- | Should we treat this as an unlifted bind? This will be true for any
858 -- bind that binds an unlifted variable, but we must be careful around
859 -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
860 -- information, see Note [Strict binds check] is DsBinds.
861 isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds
862 isUnliftedHsBind bind
863 | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
864 = if has_sig
865 then any (is_unlifted_id . abe_poly) exports
866 else any (is_unlifted_id . abe_mono) exports
867 -- If has_sig is True we wil never generate a binding for abe_mono,
868 -- so we don't need to worry about it being unlifted. The abe_poly
869 -- binding might not be: e.g. forall a. Num a => (# a, a #)
870
871 | otherwise
872 = any is_unlifted_id (collectHsBindBinders bind)
873 where
874 is_unlifted_id id = isUnliftedType (idType id)
875
876 -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
877 isBangedHsBind :: HsBind GhcTc -> Bool
878 isBangedHsBind (AbsBinds { abs_binds = binds })
879 = anyBag (isBangedHsBind . unLoc) binds
880 isBangedHsBind (FunBind {fun_matches = matches})
881 | [L _ match] <- unLoc $ mg_alts matches
882 , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
883 = True
884 isBangedHsBind (PatBind {pat_lhs = pat})
885 = isBangedLPat pat
886 isBangedHsBind _
887 = False
888
889 collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
890 -> [IdP (GhcPass idL)]
891 collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
892 -- No pattern synonyms here
893 collectLocalBinders (HsIPBinds _) = []
894 collectLocalBinders EmptyLocalBinds = []
895
896 collectHsIdBinders, collectHsValBinders
897 :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
898 -- Collect Id binders only, or Ids + pattern synonyms, respectively
899 collectHsIdBinders = collect_hs_val_binders True
900 collectHsValBinders = collect_hs_val_binders False
901
902 collectHsBindBinders :: HsBindLR idL idR -> [IdP idL]
903 -- Collect both Ids and pattern-synonym binders
904 collectHsBindBinders b = collect_bind False b []
905
906 collectHsBindsBinders :: LHsBindsLR idL idR -> [IdP idL]
907 collectHsBindsBinders binds = collect_binds False binds []
908
909 collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL]
910 -- Same as collectHsBindsBinders, but works over a list of bindings
911 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
912
913 collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
914 -> [IdP (GhcPass idL)]
915 collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
916 collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
917 = collect_out_binds ps binds
918
919 collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p]
920 collect_out_binds ps = foldr (collect_binds ps . snd) []
921
922 collect_binds :: Bool -> LHsBindsLR idL idR -> [IdP idL] -> [IdP idL]
923 -- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
924 collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
925
926 collect_bind :: Bool -> HsBindLR idL idR -> [IdP idL] -> [IdP idL]
927 collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
928 collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
929 collect_bind _ (VarBind { var_id = f }) acc = f : acc
930 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
931 -- I don't think we want the binders from the abe_binds
932
933 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
934 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
935 | omitPatSyn = acc
936 | otherwise = ps : acc
937
938 collectMethodBinders :: LHsBindsLR GhcPs idR -> [Located RdrName]
939 -- Used exclusively for the bindings of an instance decl which are all FunBinds
940 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
941 where
942 get (FunBind { fun_id = f }) fs = f : fs
943 get _ fs = fs
944 -- Someone else complains about non-FunBinds
945
946 ----------------- Statements --------------------------
947 collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
948 -> [IdP (GhcPass idL)]
949 collectLStmtsBinders = concatMap collectLStmtBinders
950
951 collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
952 -> [IdP (GhcPass idL)]
953 collectStmtsBinders = concatMap collectStmtBinders
954
955 collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
956 -> [IdP (GhcPass idL)]
957 collectLStmtBinders = collectStmtBinders . unLoc
958
959 collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
960 -> [IdP (GhcPass idL)]
961 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
962 collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
963 collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
964 collectStmtBinders (BodyStmt {}) = []
965 collectStmtBinders (LastStmt {}) = []
966 collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
967 $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
968 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
969 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
970 collectStmtBinders ApplicativeStmt{} = []
971
972
973 ----------------- Patterns --------------------------
974 collectPatBinders :: LPat a -> [IdP a]
975 collectPatBinders pat = collect_lpat pat []
976
977 collectPatsBinders :: [LPat a] -> [IdP a]
978 collectPatsBinders pats = foldr collect_lpat [] pats
979
980 -------------
981 collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass]
982 collect_lpat (L _ pat) bndrs
983 = go pat
984 where
985 go (VarPat _ (L _ var)) = var : bndrs
986 go (WildPat _) = bndrs
987 go (LazyPat _ pat) = collect_lpat pat bndrs
988 go (BangPat _ pat) = collect_lpat pat bndrs
989 go (AsPat _ (L _ a) pat) = a : collect_lpat pat bndrs
990 go (ViewPat _ _ pat) = collect_lpat pat bndrs
991 go (ParPat _ pat) = collect_lpat pat bndrs
992
993 go (ListPat _ pats _ _) = foldr collect_lpat bndrs pats
994 go (PArrPat _ pats) = foldr collect_lpat bndrs pats
995 go (TuplePat _ pats _) = foldr collect_lpat bndrs pats
996 go (SumPat _ pat _ _) = collect_lpat pat bndrs
997
998 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
999 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
1000 -- See Note [Dictionary binders in ConPatOut]
1001 go (LitPat _ _) = bndrs
1002 go (NPat {}) = bndrs
1003 go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs
1004
1005 go (SigPat _ pat) = collect_lpat pat bndrs
1006
1007 go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
1008 = go pat
1009 go (SplicePat _ _) = bndrs
1010 go (CoPat _ _ pat _) = go pat
1011 go (XPat {}) = bndrs
1012
1013 {-
1014 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
1015 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1016 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
1017 of a ConPatOut pattern. For most calls it doesn't matter, because
1018 it's pre-typechecker and there are no ConPatOuts. But it does matter
1019 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
1020 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
1021 we want to generate bindings for x,y but not for dictionaries bound by
1022 C. (The type checker ensures they would not be used.)
1023
1024 Desugaring of arrow case expressions needs these bindings (see DsArrows
1025 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
1026 own pat-binder-collector:
1027
1028 Here's the problem. Consider
1029
1030 data T a where
1031 C :: Num a => a -> Int -> T a
1032
1033 f ~(C (n+1) m) = (n,m)
1034
1035 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
1036 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
1037 variables bound by the lazy pattern are n,m, *not* the dictionary d.
1038 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
1039 -}
1040
1041 hsGroupBinders :: HsGroup GhcRn -> [Name]
1042 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
1043 hs_fords = foreign_decls })
1044 = collectHsValBinders val_decls
1045 ++ hsTyClForeignBinders tycl_decls foreign_decls
1046
1047 hsTyClForeignBinders :: [TyClGroup GhcRn]
1048 -> [LForeignDecl GhcRn]
1049 -> [Name]
1050 -- We need to look at instance declarations too,
1051 -- because their associated types may bind data constructors
1052 hsTyClForeignBinders tycl_decls foreign_decls
1053 = map unLoc (hsForeignDeclsBinders foreign_decls)
1054 ++ getSelectorNames
1055 (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
1056 `mappend`
1057 foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
1058 where
1059 getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
1060 getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs
1061
1062 -------------------
1063 hsLTyClDeclBinders :: Located (TyClDecl pass)
1064 -> ([Located (IdP pass)], [LFieldOcc pass])
1065 -- ^ Returns all the /binding/ names of the decl. The first one is
1066 -- guaranteed to be the name of the decl. The first component
1067 -- represents all binding names except record fields; the second
1068 -- represents field occurrences. For record fields mentioned in
1069 -- multiple constructors, the SrcLoc will be from the first occurrence.
1070 --
1071 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
1072 -- See Note [SrcSpan for binders]
1073
1074 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
1075 = ([L loc name], [])
1076 hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], [])
1077 hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
1078 , tcdSigs = sigs, tcdATs = ats }))
1079 = (L loc cls_name :
1080 [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
1081 [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]
1082 , [])
1083 hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
1084 = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
1085
1086 -------------------
1087 hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
1088 -- See Note [SrcSpan for binders]
1089 hsForeignDeclsBinders foreign_decls
1090 = [ L decl_loc n
1091 | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
1092
1093
1094 -------------------
1095 hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
1096 -- Collects record pattern-synonym selectors only; the pattern synonym
1097 -- names are collected by collectHsValBinders.
1098 hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
1099 hsPatSynSelectors (XValBindsLR (NValBinds binds _))
1100 = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
1101
1102 addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
1103 addPatSynSelector bind sels
1104 | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
1105 = map (unLoc . recordPatSynSelectorId) as ++ sels
1106 | otherwise = sels
1107
1108 getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
1109 getPatSynBinds binds
1110 = [ psb | (_, lbinds) <- binds
1111 , L _ (PatSynBind psb) <- bagToList lbinds ]
1112
1113 -------------------
1114 hsLInstDeclBinders :: LInstDecl pass
1115 -> ([Located (IdP pass)], [LFieldOcc pass])
1116 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
1117 = foldMap (hsDataFamInstBinders . unLoc) dfis
1118 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
1119 = hsDataFamInstBinders fi
1120 hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
1121
1122 -------------------
1123 -- the SrcLoc returned are for the whole declarations, not just the names
1124 hsDataFamInstBinders :: DataFamInstDecl pass
1125 -> ([Located (IdP pass)], [LFieldOcc pass])
1126 hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
1127 FamEqn { feqn_rhs = defn }}})
1128 = hsDataDefnBinders defn
1129 -- There can't be repeated symbols because only data instances have binders
1130
1131 -------------------
1132 -- the SrcLoc returned are for the whole declarations, not just the names
1133 hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass])
1134 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
1135 = hsConDeclsBinders cons
1136 -- See Note [Binders in family instances]
1137
1138 -------------------
1139 hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
1140 -- See hsLTyClDeclBinders for what this does
1141 -- The function is boringly complicated because of the records
1142 -- And since we only have equality, we have to be a little careful
1143 hsConDeclsBinders cons = go id cons
1144 where go :: ([LFieldOcc pass] -> [LFieldOcc pass])
1145 -> [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
1146 go _ [] = ([], [])
1147 go remSeen (r:rs) =
1148 -- don't re-mangle the location of field names, because we don't
1149 -- have a record of the full location of the field declaration anyway
1150 case r of
1151 -- remove only the first occurrence of any seen field in order to
1152 -- avoid circumventing detection of duplicate fields (#9156)
1153 L loc (ConDeclGADT { con_names = names
1154 , con_type = HsIB { hsib_body = res_ty}}) ->
1155 case tau of
1156 L _ (HsFunTy _
1157 (L _ (HsAppsTy _
1158 [L _ (HsAppPrefix _ (L _ (HsRecTy _ flds)))])) _)
1159 -> record_gadt flds
1160 L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _res_ty)
1161 -> record_gadt flds
1162
1163 _other -> (map (L loc . unLoc) names ++ ns, fs)
1164 where (ns, fs) = go remSeen rs
1165 where
1166 (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
1167 record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
1168 where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
1169 remSeen' = foldr (.) remSeen
1170 [deleteBy ((==) `on`
1171 unLoc . rdrNameFieldOcc . unLoc) v
1172 | v <- r']
1173 (ns, fs) = go remSeen' rs
1174
1175 L loc (ConDeclH98 { con_name = name
1176 , con_details = RecCon flds }) ->
1177 ([L loc (unLoc name)] ++ ns, r' ++ fs)
1178 where r' = remSeen (concatMap (cd_fld_names . unLoc)
1179 (unLoc flds))
1180 remSeen'
1181 = foldr (.) remSeen
1182 [deleteBy ((==) `on`
1183 unLoc . rdrNameFieldOcc . unLoc) v | v <- r']
1184 (ns, fs) = go remSeen' rs
1185 L loc (ConDeclH98 { con_name = name }) ->
1186 ([L loc (unLoc name)] ++ ns, fs)
1187 where (ns, fs) = go remSeen rs
1188
1189 {-
1190
1191 Note [SrcSpan for binders]
1192 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1193 When extracting the (Located RdrNme) for a binder, at least for the
1194 main name (the TyCon of a type declaration etc), we want to give it
1195 the @SrcSpan@ of the whole /declaration/, not just the name itself
1196 (which is how it appears in the syntax tree). This SrcSpan (for the
1197 entire declaration) is used as the SrcSpan for the Name that is
1198 finally produced, and hence for error messages. (See Trac #8607.)
1199
1200 Note [Binders in family instances]
1201 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1202 In a type or data family instance declaration, the type
1203 constructor is an *occurrence* not a binding site
1204 type instance T Int = Int -> Int -- No binders
1205 data instance S Bool = S1 | S2 -- Binders are S1,S2
1206
1207
1208 ************************************************************************
1209 * *
1210 Collecting binders the user did not write
1211 * *
1212 ************************************************************************
1213
1214 The job of this family of functions is to run through binding sites and find the set of all Names
1215 that were defined "implicitly", without being explicitly written by the user.
1216
1217 The main purpose is to find names introduced by record wildcards so that we can avoid
1218 warning the user when they don't use those names (#4404)
1219 -}
1220
1221 lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
1222 -> NameSet
1223 lStmtsImplicits = hs_lstmts
1224 where
1225 hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
1226 -> NameSet
1227 hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
1228
1229 hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
1230 -> NameSet
1231 hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat
1232 hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
1233 where do_arg (_, ApplicativeArgOne pat _ _) = lPatImplicits pat
1234 do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts
1235 hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds)
1236 hs_stmt (BodyStmt {}) = emptyNameSet
1237 hs_stmt (LastStmt {}) = emptyNameSet
1238 hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
1239 , 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