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