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