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