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