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