be01baa4ea363ad5291199b45f87a2b1b35d666c
[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,
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 -------------
323 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
324 -- Caller sets location
325 userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
326
327 {-
328 ************************************************************************
329 * *
330 Constructing syntax with no location info
331 * *
332 ************************************************************************
333 -}
334
335 nlHsVar :: id -> LHsExpr id
336 nlHsVar n = noLoc (HsVar n)
337
338 nlHsLit :: HsLit -> LHsExpr id
339 nlHsLit n = noLoc (HsLit n)
340
341 nlVarPat :: id -> LPat id
342 nlVarPat n = noLoc (VarPat n)
343
344 nlLitPat :: HsLit -> LPat id
345 nlLitPat l = noLoc (LitPat l)
346
347 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
348 nlHsApp f x = noLoc (HsApp f x)
349
350 nlHsIntLit :: Integer -> LHsExpr id
351 nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
352
353 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
354 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
355
356 nlHsVarApps :: id -> [id] -> LHsExpr id
357 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
358 where
359 mk f a = HsApp (noLoc f) (noLoc a)
360
361 nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
362 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
363
364 nlConVarPatName :: Name -> [Name] -> LPat Name
365 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
366
367 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
368 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
369
370 nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
371 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
372
373 nlConPatName :: Name -> [LPat Name] -> LPat Name
374 nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
375
376 nlNullaryConPat :: id -> LPat id
377 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
378
379 nlWildConPat :: DataCon -> LPat RdrName
380 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
381 (PrefixCon (nOfThem (dataConSourceArity con)
382 nlWildPat)))
383
384 nlWildPat :: LPat RdrName
385 nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking
386
387 nlWildPatName :: LPat Name
388 nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking
389
390 nlWildPatId :: LPat Id
391 nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking
392
393 nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)]
394 -> LHsExpr RdrName
395 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
396
397 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
398 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
399
400 nlHsLam :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName
401 nlHsPar :: LHsExpr id -> LHsExpr id
402 nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
403 nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
404 -> LHsExpr RdrName
405 nlList :: [LHsExpr RdrName] -> LHsExpr RdrName
406
407 nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
408 nlHsPar e = noLoc (HsPar e)
409 nlHsIf cond true false = noLoc (mkHsIf cond true false)
410 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
411 nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
412
413 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
414 nlHsTyVar :: name -> LHsType name
415 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
416
417 nlHsAppTy f t = noLoc (HsAppTy f t)
418 nlHsTyVar x = noLoc (HsTyVar x)
419 nlHsFunTy a b = noLoc (HsFunTy a b)
420
421 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
422 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
423
424 {-
425 Tuples. All these functions are *pre-typechecker* because they lack
426 types on the tuple.
427 -}
428
429 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
430 -- Makes a pre-typechecker boxed tuple, deals with 1 case
431 mkLHsTupleExpr [e] = e
432 mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
433
434 mkLHsVarTuple :: [a] -> LHsExpr a
435 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
436
437 nlTuplePat :: [LPat id] -> Boxity -> LPat id
438 nlTuplePat pats box = noLoc (TuplePat pats box [])
439
440 missingTupArg :: HsTupArg RdrName
441 missingTupArg = Missing placeHolderType
442
443 mkLHsPatTup :: [LPat id] -> LPat id
444 mkLHsPatTup [] = noLoc $ TuplePat [] Boxed []
445 mkLHsPatTup [lpat] = lpat
446 mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
447
448 -- The Big equivalents for the source tuple expressions
449 mkBigLHsVarTup :: [id] -> LHsExpr id
450 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
451
452 mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
453 mkBigLHsTup = mkChunkified mkLHsTupleExpr
454
455 -- The Big equivalents for the source tuple patterns
456 mkBigLHsVarPatTup :: [id] -> LPat id
457 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
458
459 mkBigLHsPatTup :: [LPat id] -> LPat id
460 mkBigLHsPatTup = mkChunkified mkLHsPatTup
461
462 -- $big_tuples
463 -- #big_tuples#
464 --
465 -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
466 -- we might concievably want to build such a massive tuple as part of the
467 -- output of a desugaring stage (notably that for list comprehensions).
468 --
469 -- We call tuples above this size \"big tuples\", and emulate them by
470 -- creating and pattern matching on >nested< tuples that are expressible
471 -- by GHC.
472 --
473 -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
474 -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
475 -- construction to be big.
476 --
477 -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
478 -- and 'mkTupleCase' functions to do all your work with tuples you should be
479 -- fine, and not have to worry about the arity limitation at all.
480
481 -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
482 mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
483 -> [a] -- ^ Possible \"big\" list of things to construct from
484 -> a -- ^ Constructed thing made possible by recursive decomposition
485 mkChunkified small_tuple as = mk_big_tuple (chunkify as)
486 where
487 -- Each sub-list is short enough to fit in a tuple
488 mk_big_tuple [as] = small_tuple as
489 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
490
491 chunkify :: [a] -> [[a]]
492 -- ^ Split a list into lists that are small enough to have a corresponding
493 -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
494 -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
495 chunkify xs
496 | n_xs <= mAX_TUPLE_SIZE = [xs]
497 | otherwise = split xs
498 where
499 n_xs = length xs
500 split [] = []
501 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
502
503 {-
504 ************************************************************************
505 * *
506 Converting a Type to an HsType RdrName
507 * *
508 ************************************************************************
509
510 This is needed to implement GeneralizedNewtypeDeriving.
511 -}
512
513 toHsType :: Type -> LHsType RdrName
514 toHsType ty
515 | [] <- tvs_only
516 , [] <- theta
517 = to_hs_type tau
518 | otherwise
519 = noLoc $
520 mkExplicitHsForAllTy (map mk_hs_tvb tvs_only)
521 (noLoc $ map toHsType theta)
522 (to_hs_type tau)
523
524 where
525 (tvs, theta, tau) = tcSplitSigmaTy ty
526 tvs_only = filter isTypeVar tvs
527
528 to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv)
529 to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2)
530 to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args')
531 where
532 args' = filterOut isKind args
533 -- Source-language types have _implicit_ kind arguments,
534 -- so we must remove them here (Trac #8563)
535 to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
536 nlHsFunTy (toHsType arg) (toHsType res)
537 to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
538 to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
539 to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
540
541 mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
542 (toHsKind (tyVarKind tv))
543
544 toHsKind :: Kind -> LHsKind RdrName
545 toHsKind = toHsType
546
547 --------- HsWrappers: type args, dict args, casts ---------
548 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
549 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
550
551 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
552 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
553 | otherwise = HsWrap co_fn e
554
555 mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
556 -> HsExpr id -> HsExpr id
557 mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e
558
559 mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
560 -> HsExpr id -> HsExpr id
561 mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e
562
563 mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id
564 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
565
566 mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
567 mkHsCmdCast co cmd | isTcReflCo co = cmd
568 | otherwise = HsCmdCast co cmd
569
570 coToHsWrapper :: TcCoercion -> HsWrapper -- A Nominal coercion
571 coToHsWrapper co | isTcReflCo co = idHsWrapper
572 | otherwise = mkWpCast (mkTcSubCo co)
573
574 coToHsWrapperR :: TcCoercion -> HsWrapper -- A Representational coercion
575 coToHsWrapperR co | isTcReflCo co = idHsWrapper
576 | otherwise = mkWpCast co
577
578 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
579 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
580 | otherwise = CoPat co_fn p ty
581
582 -- input coercion is Nominal
583 mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
584 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
585 | otherwise = CoPat (mkWpCast (mkTcSubCo co)) pat ty
586
587 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
588 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
589
590 {-
591 l
592 ************************************************************************
593 * *
594 Bindings; with a location at the top
595 * *
596 ************************************************************************
597 -}
598
599 mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
600 -> HsBind RdrName
601 -- Not infix, with place holders for coercion and free vars
602 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
603 , fun_matches = mkMatchGroup Generated ms
604 , fun_co_fn = idHsWrapper
605 , bind_fvs = placeHolderNames
606 , fun_tick = [] }
607
608 mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
609 -> HsBind Name
610 -- In Name-land, with empty bind_fvs
611 mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
612 , fun_matches = mkMatchGroupName origin ms
613 , fun_co_fn = idHsWrapper
614 , bind_fvs = emptyNameSet -- NB: closed
615 -- binding
616 , fun_tick = [] }
617
618 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
619 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
620
621 mkVarBind :: id -> LHsExpr id -> LHsBind id
622 mkVarBind var rhs = L (getLoc rhs) $
623 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
624
625 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
626 -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
627 mkPatSynBind name details lpat dir = PatSynBind psb
628 where
629 psb = PSB{ psb_id = name
630 , psb_args = details
631 , psb_def = lpat
632 , psb_dir = dir
633 , psb_fvs = placeHolderNames }
634
635 ------------
636 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
637 -> LHsExpr RdrName -> LHsBind RdrName
638 mk_easy_FunBind loc fun pats expr
639 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
640
641 ------------
642 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
643 mkMatch pats expr binds
644 = noLoc (Match Nothing (map paren pats) Nothing
645 (GRHSs (unguardedRHS noSrcSpan expr) binds))
646 where
647 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
648 | otherwise = lp
649
650 {-
651 ************************************************************************
652 * *
653 Collecting binders
654 * *
655 ************************************************************************
656
657 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
658
659 ...
660 where
661 (x, y) = ...
662 f i j = ...
663 [a, b] = ...
664
665 it should return [x, y, f, a, b] (remember, order important).
666
667 Note [Collect binders only after renaming]
668 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
669 These functions should only be used on HsSyn *after* the renamer,
670 to return a [Name] or [Id]. Before renaming the record punning
671 and wild-card mechanism makes it hard to know what is bound.
672 So these functions should not be applied to (HsSyn RdrName)
673 -}
674
675 ----------------- Bindings --------------------------
676 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
677 collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
678 -- No pattern synonyms here
679 collectLocalBinders (HsIPBinds _) = []
680 collectLocalBinders EmptyLocalBinds = []
681
682 collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
683 -- Collect Id binders only, or Ids + pattern synonmys, respectively
684 collectHsIdBinders = collect_hs_val_binders True
685 collectHsValBinders = collect_hs_val_binders False
686
687 collectHsBindBinders :: HsBindLR idL idR -> [idL]
688 -- Collect both Ids and pattern-synonym binders
689 collectHsBindBinders b = collect_bind False b []
690
691 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
692 collectHsBindsBinders binds = collect_binds False binds []
693
694 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
695 -- Same as collectHsBindsBinders, but works over a list of bindings
696 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
697
698 collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
699 collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
700 collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
701
702 collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
703 collect_out_binds ps = foldr (collect_binds ps . snd) []
704
705 collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
706 -- Collect Ids, or Ids + patter synonyms, depending on boolean flag
707 collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
708
709 collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
710 collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
711 collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
712 collect_bind _ (VarBind { var_id = f }) acc = f : acc
713 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
714 -- I don't think we want the binders from the abe_binds
715 -- The only time we collect binders from a typechecked
716 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
717 collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
718 if omitPatSyn then acc else ps : acc
719
720 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
721 -- Used exclusively for the bindings of an instance decl which are all FunBinds
722 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
723 where
724 get (FunBind { fun_id = f }) fs = f : fs
725 get _ fs = fs
726 -- Someone else complains about non-FunBinds
727
728 ----------------- Statements --------------------------
729 collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
730 collectLStmtsBinders = concatMap collectLStmtBinders
731
732 collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
733 collectStmtsBinders = concatMap collectStmtBinders
734
735 collectLStmtBinders :: LStmtLR idL idR body -> [idL]
736 collectLStmtBinders = collectStmtBinders . unLoc
737
738 collectStmtBinders :: StmtLR idL idR body -> [idL]
739 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
740 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
741 collectStmtBinders (LetStmt binds) = collectLocalBinders binds
742 collectStmtBinders (BodyStmt {}) = []
743 collectStmtBinders (LastStmt {}) = []
744 collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
745 $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
746 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
747 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
748 collectStmtBinders ApplicativeStmt{} = []
749
750
751 ----------------- Patterns --------------------------
752 collectPatBinders :: LPat a -> [a]
753 collectPatBinders pat = collect_lpat pat []
754
755 collectPatsBinders :: [LPat a] -> [a]
756 collectPatsBinders pats = foldr collect_lpat [] pats
757
758 -------------
759 collect_lpat :: LPat name -> [name] -> [name]
760 collect_lpat (L _ pat) bndrs
761 = go pat
762 where
763 go (VarPat var) = var : bndrs
764 go (WildPat _) = bndrs
765 go (LazyPat pat) = collect_lpat pat bndrs
766 go (BangPat pat) = collect_lpat pat bndrs
767 go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
768 go (ViewPat _ pat _) = collect_lpat pat bndrs
769 go (ParPat pat) = collect_lpat pat bndrs
770
771 go (ListPat pats _ _) = foldr collect_lpat bndrs pats
772 go (PArrPat pats _) = foldr collect_lpat bndrs pats
773 go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
774
775 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
776 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
777 -- See Note [Dictionary binders in ConPatOut]
778 go (LitPat _) = bndrs
779 go (NPat _ _ _) = bndrs
780 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
781
782 go (SigPatIn pat _) = collect_lpat pat bndrs
783 go (SigPatOut pat _) = collect_lpat pat bndrs
784 go (SplicePat _) = bndrs
785 go (CoPat _ pat _) = go pat
786
787 {-
788 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
789 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
790 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
791 of a ConPatOut pattern. For most calls it doesn't matter, because
792 it's pre-typechecker and there are no ConPatOuts. But it does matter
793 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
794 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
795 we want to generate bindings for x,y but not for dictionaries bound by
796 C. (The type checker ensures they would not be used.)
797
798 Desugaring of arrow case expressions needs these bindings (see DsArrows
799 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
800 own pat-binder-collector:
801
802 Here's the problem. Consider
803
804 data T a where
805 C :: Num a => a -> Int -> T a
806
807 f ~(C (n+1) m) = (n,m)
808
809 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
810 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
811 variables bound by the lazy pattern are n,m, *not* the dictionary d.
812 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
813 -}
814
815 hsGroupBinders :: HsGroup Name -> [Name]
816 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
817 hs_instds = inst_decls, hs_fords = foreign_decls })
818 = collectHsValBinders val_decls
819 ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
820
821 hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
822 -> [LForeignDecl Name] -> [Name]
823 -- We need to look at instance declarations too,
824 -- because their associated types may bind data constructors
825 hsTyClForeignBinders tycl_decls inst_decls foreign_decls
826 = map unLoc (hsForeignDeclsBinders foreign_decls)
827 ++ getSelectorNames (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
828 `mappend` foldMap hsLInstDeclBinders inst_decls)
829 where
830 getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name]
831 getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
832
833 -------------------
834 hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name])
835 -- ^ Returns all the /binding/ names of the decl. The first one is
836 -- guaranteed to be the name of the decl. The first component
837 -- represents all binding names except record fields; the second
838 -- represents field occurrences. For record fields mentioned in
839 -- multiple constructors, the SrcLoc will be from the first occurrence.
840 --
841 -- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
842 -- See Note [SrcSpan for binders]
843
844 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
845 = ([L loc name], [])
846 hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], [])
847 hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
848 , tcdSigs = sigs, tcdATs = ats }))
849 = (L loc cls_name :
850 [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
851 [ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ]
852 , [])
853 hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
854 = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
855
856 -------------------
857 hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
858 -- See Note [SrcSpan for binders]
859 hsForeignDeclsBinders foreign_decls
860 = [ L decl_loc n
861 | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
862
863
864
865 -------------------
866 hsPatSynBinders :: HsValBinds RdrName
867 -> ([Located RdrName], [Located RdrName])
868 -- Collect pattern-synonym binders only, not Ids
869 -- See Note [SrcSpan for binders]
870 hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds
871 hsPatSynBinders _ = panic "hsPatSynBinders"
872
873 addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id])
874 -> ([Located id], [Located id]) -- (selectors, other)
875 -- See Note [SrcSpan for binders]
876 addPatSynBndr bind (sels, pss)
877 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
878 , psb_args = RecordPatSyn as })) <- bind
879 = (map recordPatSynSelectorId as ++ sels, L bind_loc n : pss)
880 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
881 = (sels, L bind_loc n : pss)
882 | otherwise
883 = (sels, pss)
884
885 -------------------
886 hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
887 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
888 = foldMap (hsDataFamInstBinders . unLoc) dfis
889 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
890 = hsDataFamInstBinders fi
891 hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
892
893 -------------------
894 -- the SrcLoc returned are for the whole declarations, not just the names
895 hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name])
896 hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
897 = hsDataDefnBinders defn
898 -- There can't be repeated symbols because only data instances have binders
899
900 -------------------
901 -- the SrcLoc returned are for the whole declarations, not just the names
902 hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name])
903 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
904 = hsConDeclsBinders cons
905 -- See Note [Binders in family instances]
906
907 -------------------
908 hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name])
909 -- See hsLTyClDeclBinders for what this does
910 -- The function is boringly complicated because of the records
911 -- And since we only have equality, we have to be a little careful
912 hsConDeclsBinders cons = go id cons
913 where go :: ([LFieldOcc name] -> [LFieldOcc name])
914 -> [LConDecl name] -> ([Located name], [LFieldOcc name])
915 go _ [] = ([], [])
916 go remSeen (r:rs) =
917 -- don't re-mangle the location of field names, because we don't
918 -- have a record of the full location of the field declaration anyway
919 case r of
920 -- remove only the first occurrence of any seen field in order to
921 -- avoid circumventing detection of duplicate fields (#9156)
922 L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
923 (map (L loc . unLoc) names ++ ns, r' ++ fs)
924 where r' = remSeen (concatMap (cd_fld_names . unLoc)
925 (unLoc flds))
926 remSeen' = foldr (.) remSeen [deleteBy ((==) `on` rdrNameFieldOcc . unLoc) v | v <- r']
927 (ns, fs) = go remSeen' rs
928 L loc (ConDecl { con_names = names }) ->
929 (map (L loc . unLoc) names ++ ns, fs)
930 where (ns, fs) = go remSeen rs
931
932 {-
933
934 Note [SrcSpan for binders]
935 ~~~~~~~~~~~~~~~~~~~~~~~~~~
936 When extracting the (Located RdrNme) for a binder, at least for the
937 main name (the TyCon of a type declaration etc), we want to give it
938 the @SrcSpan@ of the whole /declaration/, not just the name itself
939 (which is how it appears in the syntax tree). This SrcSpan (for the
940 entire declaration) is used as the SrcSpan for the Name that is
941 finally produced, and hence for error messages. (See Trac #8607.)
942
943 Note [Binders in family instances]
944 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
945 In a type or data family instance declaration, the type
946 constructor is an *occurrence* not a binding site
947 type instance T Int = Int -> Int -- No binders
948 data instance S Bool = S1 | S2 -- Binders are S1,S2
949
950
951 ************************************************************************
952 * *
953 Collecting binders the user did not write
954 * *
955 ************************************************************************
956
957 The job of this family of functions is to run through binding sites and find the set of all Names
958 that were defined "implicitly", without being explicitly written by the user.
959
960 The main purpose is to find names introduced by record wildcards so that we can avoid
961 warning the user when they don't use those names (#4404)
962 -}
963
964 lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet
965 lStmtsImplicits = hs_lstmts
966 where
967 hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet
968 hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
969
970 hs_stmt :: StmtLR Name idR (Located (body idR)) -> NameSet
971 hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
972 hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
973 where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat
974 do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts
975 hs_stmt (LetStmt binds) = hs_local_binds binds
976 hs_stmt (BodyStmt {}) = emptyNameSet
977 hs_stmt (LastStmt {}) = emptyNameSet
978 hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
979 hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
980 hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
981
982 hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
983 hs_local_binds (HsIPBinds _) = emptyNameSet
984 hs_local_binds EmptyLocalBinds = emptyNameSet
985
986 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
987 hsValBindsImplicits (ValBindsOut binds _)
988 = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
989 hsValBindsImplicits (ValBindsIn binds _)
990 = lhsBindsImplicits binds
991
992 lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
993 lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
994 where
995 lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
996 lhs_bind _ = emptyNameSet
997
998 lPatImplicits :: LPat Name -> NameSet
999 lPatImplicits = hs_lpat
1000 where
1001 hs_lpat (L _ pat) = hs_pat pat
1002
1003 hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
1004
1005 hs_pat (LazyPat pat) = hs_lpat pat
1006 hs_pat (BangPat pat) = hs_lpat pat
1007 hs_pat (AsPat _ pat) = hs_lpat pat
1008 hs_pat (ViewPat _ pat _) = hs_lpat pat
1009 hs_pat (ParPat pat) = hs_lpat pat
1010 hs_pat (ListPat pats _ _) = hs_lpats pats
1011 hs_pat (PArrPat pats _) = hs_lpats pats
1012 hs_pat (TuplePat pats _ _) = hs_lpats pats
1013
1014 hs_pat (SigPatIn pat _) = hs_lpat pat
1015 hs_pat (SigPatOut pat _) = hs_lpat pat
1016 hs_pat (CoPat _ pat _) = hs_pat pat
1017
1018 hs_pat (ConPatIn _ ps) = details ps
1019 hs_pat (ConPatOut {pat_args=ps}) = details ps
1020
1021 hs_pat _ = emptyNameSet
1022
1023 details (PrefixCon ps) = hs_lpats ps
1024 details (RecCon fs) = hs_lpats explicit `unionNameSet` mkNameSet (collectPatsBinders implicit)
1025 where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
1026 | (i, fld) <- [0..] `zip` rec_flds fs
1027 , let pat = hsRecFieldArg
1028 (unLoc fld)
1029 pat_explicit = maybe True (i<) (rec_dotdot fs)]
1030 details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2