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