Hurrah! This major commit adds support for scoped kind variables,
[ghc.git] / compiler / hsSyn / HsUtils.lhs
1
2 %
3 % (c) The University of Glasgow, 1992-2006
4 %
5
6 Here we collect a variety of helper functions that construct or
7 analyse HsSyn.  All these functions deal with generic HsSyn; functions
8 which deal with the intantiated versions are located elsewhere:
9
10    Parameterised by     Module
11    ----------------     -------------
12    RdrName              parser/RdrHsSyn
13    Name                 rename/RnHsSyn
14    Id                   typecheck/TcHsSyn       
15
16 \begin{code}
17 {-# OPTIONS -fno-warn-tabs #-}
18 -- The above warning supression flag is a temporary kludge.
19 -- While working on this module you are encouraged to remove it and
20 -- detab the module (please do the detabbing in a separate patch). See
21 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
22 -- for details
23
24 module HsUtils(
25   -- Terms
26   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
27   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
28   mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
29   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
30   coToHsWrapper, mkHsDictLet, mkHsLams,
31   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
32   mkLHsPar, 
33
34   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
35   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
36   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
37
38   -- Bindings
39   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
40
41   -- Literals
42   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, 
43
44   -- Patterns
45   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
46   nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, mkParPat,
47
48   -- Types
49   mkHsAppTy, userHsTyVarBndrs,
50   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, 
51
52   -- Stmts
53   mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
54   emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, 
55   emptyRecStmt, mkRecStmt, 
56
57   -- Template Haskell
58   unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
59
60   -- Flags
61   noRebindableInfo, 
62
63   -- Collecting binders
64   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
65   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
66   collectPatBinders, collectPatsBinders,
67   collectLStmtsBinders, collectStmtsBinders,
68   collectLStmtBinders, collectStmtBinders,
69   collectSigTysFromPats, collectSigTysFromPat,
70
71   hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, 
72   hsForeignDeclsBinders, hsGroupBinders,
73   
74   -- Collecting implicit binders
75   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
76   ) where
77
78 import HsDecls
79 import HsBinds
80 import HsExpr
81 import HsPat
82 import HsTypes  
83 import HsLit
84
85 import TcEvidence
86 import RdrName
87 import Var
88 import TypeRep
89 import DataCon
90 import Name
91 import NameSet
92 import BasicTypes
93 import SrcLoc
94 import FastString
95 import Util
96 import Bag
97
98 import Data.Either
99 import Data.Maybe
100 \end{code}
101
102
103 %************************************************************************
104 %*                                                                      *
105         Some useful helpers for constructing syntax
106 %*                                                                      *
107 %************************************************************************
108
109 These functions attempt to construct a not-completely-useless SrcSpan
110 from their components, compared with the nl* functions below which
111 just attach noSrcSpan to everything.
112
113 \begin{code}
114 mkHsPar :: LHsExpr id -> LHsExpr id
115 mkHsPar e = L (getLoc e) (HsPar e)
116
117 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
118 mkSimpleMatch pats rhs 
119   = L loc $
120     Match pats Nothing (unguardedGRHSs rhs)
121   where
122     loc = case pats of
123                 []      -> getLoc rhs
124                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
125
126 unguardedGRHSs :: LHsExpr id -> GRHSs id
127 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
128
129 unguardedRHS :: LHsExpr id -> [LGRHS id]
130 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
131
132 mkMatchGroup :: [LMatch id] -> MatchGroup id
133 mkMatchGroup matches = MatchGroup matches placeHolderType
134
135 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
136 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
137
138 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
139 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
140
141 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
142 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
143         where
144           matches = mkMatchGroup [mkSimpleMatch pats body]
145
146 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
147 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
148
149 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
150 -- Used for constructing dictionary terms etc, so no locations 
151 mkHsConApp data_con tys args 
152   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
153   where
154     mk_app f a = noLoc (HsApp f (noLoc a))
155
156 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
157 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
158 mkSimpleHsAlt pat expr 
159   = mkSimpleMatch [pat] expr
160
161 nlHsTyApp :: name -> [Type] -> LHsExpr name
162 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
163
164 --------- Adding parens ---------
165 mkLHsPar :: LHsExpr name -> LHsExpr name
166 -- Wrap in parens if hsExprNeedsParens says it needs them
167 -- So   'f x'  becomes '(f x)', but '3' stays as '3'
168 mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
169                       | otherwise           = le
170
171 mkParPat :: LPat name -> LPat name
172 mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
173                       | otherwise          = lp
174
175
176 -------------------------------
177 -- These are the bits of syntax that contain rebindable names
178 -- See RnEnv.lookupSyntaxName
179
180 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
181 mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id
182 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
183 mkHsDo         :: HsStmtContext Name -> [LStmt id] -> HsExpr id
184 mkHsComp       :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
185
186 mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
187 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
188
189 mkLastStmt :: LHsExpr idR -> StmtLR idL idR
190 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
191 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
192
193 emptyRecStmt :: StmtLR idL idR
194 mkRecStmt    :: [LStmtLR idL idR] -> StmtLR idL idR
195
196
197 mkHsIntegral   i       = OverLit (HsIntegral   i)  noRebindableInfo noSyntaxExpr
198 mkHsFractional f       = OverLit (HsFractional f)  noRebindableInfo noSyntaxExpr
199 mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr
200
201 noRebindableInfo :: Bool
202 noRebindableInfo = error "noRebindableInfo"     -- Just another placeholder; 
203
204 mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType
205 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
206   where
207     last_stmt = L (getLoc expr) $ mkLastStmt expr
208
209 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
210 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
211
212 mkNPat lit neg     = NPat lit neg noSyntaxExpr
213 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
214
215 mkTransformStmt    :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
216 mkTransformByStmt  :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
217 mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
218 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
219
220 emptyTransStmt :: StmtLR idL idR
221 emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] 
222                            , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
223                            , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
224                            , trS_fmap = noSyntaxExpr }
225 mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
226 mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
227 mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
228 mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
229
230 mkLastStmt expr     = LastStmt expr noSyntaxExpr
231 mkExprStmt expr     = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
232 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
233
234 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
235                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
236                        , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
237                        , recS_rec_rets = [], recS_ret_ty = placeHolderType }
238
239 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
240
241 -------------------------------
242 --- A useful function for building @OpApps@.  The operator is always a
243 -- variable, and we don't know the fixity yet.
244 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
245 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
246
247 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
248 mkHsSplice e = HsSplice unqualSplice e
249
250 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
251 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
252
253 unqualSplice :: RdrName
254 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
255                 -- A name (uniquified later) to
256                 -- identify the splice
257
258 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
259 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
260
261 unqualQuasiQuote :: RdrName
262 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
263                 -- A name (uniquified later) to
264                 -- identify the quasi-quote
265
266 mkHsString :: String -> HsLit
267 mkHsString s = HsString (mkFastString s)
268
269 -------------
270 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
271 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
272 \end{code}
273
274
275 %************************************************************************
276 %*                                                                      *
277         Constructing syntax with no location info
278 %*                                                                      *
279 %************************************************************************
280
281 \begin{code}
282 nlHsVar :: id -> LHsExpr id
283 nlHsVar n = noLoc (HsVar n)
284
285 nlHsLit :: HsLit -> LHsExpr id
286 nlHsLit n = noLoc (HsLit n)
287
288 nlVarPat :: id -> LPat id
289 nlVarPat n = noLoc (VarPat n)
290
291 nlLitPat :: HsLit -> LPat id
292 nlLitPat l = noLoc (LitPat l)
293
294 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
295 nlHsApp f x = noLoc (HsApp f x)
296
297 nlHsIntLit :: Integer -> LHsExpr id
298 nlHsIntLit n = noLoc (HsLit (HsInt n))
299
300 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
301 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
302              
303 nlHsVarApps :: id -> [id] -> LHsExpr id
304 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
305                  where
306                    mk f a = HsApp (noLoc f) (noLoc a)
307
308 nlConVarPat :: id -> [id] -> LPat id
309 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
310
311 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
312 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
313
314 nlConPat :: id -> [LPat id] -> LPat id
315 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
316
317 nlNullaryConPat :: id -> LPat id
318 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
319
320 nlWildConPat :: DataCon -> LPat RdrName
321 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
322                                    (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
323
324 nlWildPat :: LPat id
325 nlWildPat  = noLoc (WildPat placeHolderType)    -- Pre-typechecking
326
327 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
328 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
329
330 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
331 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
332
333 nlHsLam  :: LMatch id -> LHsExpr id
334 nlHsPar  :: LHsExpr id -> LHsExpr id
335 nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
336 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
337 nlList   :: [LHsExpr id] -> LHsExpr id
338
339 nlHsLam match           = noLoc (HsLam (mkMatchGroup [match]))
340 nlHsPar e               = noLoc (HsPar e)
341 nlHsIf cond true false  = noLoc (mkHsIf cond true false)
342 nlHsCase expr matches   = noLoc (HsCase expr (mkMatchGroup matches))
343 nlList exprs            = noLoc (ExplicitList placeHolderType exprs)
344
345 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
346 nlHsTyVar :: name                         -> LHsType name
347 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
348
349 nlHsAppTy f t           = noLoc (HsAppTy f t)
350 nlHsTyVar x             = noLoc (HsTyVar x)
351 nlHsFunTy a b           = noLoc (HsFunTy a b)
352
353 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
354 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
355 \end{code}
356
357 Tuples.  All these functions are *pre-typechecker* because they lack
358 types on the tuple.
359
360 \begin{code}
361 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
362 -- Makes a pre-typechecker boxed tuple, deals with 1 case
363 mkLHsTupleExpr [e] = e
364 mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
365
366 mkLHsVarTuple :: [a] -> LHsExpr a
367 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
368
369 nlTuplePat :: [LPat id] -> Boxity -> LPat id
370 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
371
372 missingTupArg :: HsTupArg a
373 missingTupArg = Missing placeHolderType
374 \end{code}
375
376 \begin{code}
377 --------- HsWrappers: type args, dict args, casts ---------
378 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
379 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
380
381 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
382 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
383                  | otherwise           = HsWrap co_fn e
384
385 mkHsWrapCo :: TcCoercion -> HsExpr id -> HsExpr id
386 mkHsWrapCo co e | isTcReflCo co = e
387                 | otherwise     = mkHsWrap (WpCast co) e
388
389 mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id
390 mkLHsWrapCo co (L loc e) | isTcReflCo co = L loc e
391                          | otherwise     = L loc (mkHsWrap (WpCast co) e)
392
393 coToHsWrapper :: TcCoercion -> HsWrapper
394 coToHsWrapper co | isTcReflCo co = idHsWrapper
395                  | otherwise     = WpCast co
396
397 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
398 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
399                        | otherwise           = CoPat co_fn p ty
400
401 mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id
402 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
403                         | otherwise     = CoPat (WpCast co) pat ty
404
405 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
406 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
407 \end{code}
408 l
409 %************************************************************************
410 %*                                                                      *
411                 Bindings; with a location at the top
412 %*                                                                      *
413 %************************************************************************
414
415 \begin{code}
416 mkFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName
417 -- Not infix, with place holders for coercion and free vars
418 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
419                           , fun_matches = mkMatchGroup ms
420                           , fun_co_fn = idHsWrapper
421                           , bind_fvs = placeHolderNames
422                           , fun_tick = Nothing }
423
424 mkTopFunBind :: Located Name -> [LMatch Name] -> HsBind Name
425 -- In Name-land, with empty bind_fvs
426 mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
427                              , fun_matches = mkMatchGroup ms
428                              , fun_co_fn = idHsWrapper
429                              , bind_fvs = emptyNameSet  -- NB: closed binding
430                              , fun_tick = Nothing }
431
432 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
433 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
434
435 mkVarBind :: id -> LHsExpr id -> LHsBind id
436 mkVarBind var rhs = L (getLoc rhs) $
437                     VarBind { var_id = var, var_rhs = rhs, var_inline = False }
438
439 ------------
440 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
441                 -> LHsExpr RdrName -> LHsBind RdrName
442 mk_easy_FunBind loc fun pats expr
443   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
444
445 ------------
446 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
447 mkMatch pats expr binds
448   = noLoc (Match (map paren pats) Nothing 
449                  (GRHSs (unguardedRHS expr) binds))
450   where
451     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) 
452                      | otherwise          = lp
453 \end{code}
454
455
456 %************************************************************************
457 %*                                                                      *
458         Collecting binders
459 %*                                                                      *
460 %************************************************************************
461
462 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
463
464 ...
465 where
466   (x, y) = ...
467   f i j  = ...
468   [a, b] = ...
469
470 it should return [x, y, f, a, b] (remember, order important).
471
472 Note [Collect binders only after renaming]
473 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
474 These functions should only be used on HsSyn *after* the renamer,
475 to return a [Name] or [Id].  Before renaming the record punning
476 and wild-card mechanism makes it hard to know what is bound.
477 So these functions should not be applied to (HsSyn RdrName)
478
479 \begin{code}
480 ----------------- Bindings --------------------------
481 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
482 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
483 collectLocalBinders (HsIPBinds _)   = []
484 collectLocalBinders EmptyLocalBinds = []
485
486 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
487 collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
488 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
489   where
490    collect_one (_,binds) acc = collect_binds binds acc
491
492 collectHsBindBinders :: HsBindLR idL idR -> [idL]
493 collectHsBindBinders b = collect_bind b []
494
495 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
496 collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
497 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
498 collect_bind (VarBind { var_id = f })     acc = f : acc
499 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
500   = map abe_poly dbinds ++ acc 
501         -- ++ foldr collect_bind acc binds
502         -- I don't think we want the binders from the nested binds
503         -- The only time we collect binders from a typechecked 
504         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
505
506 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
507 collectHsBindsBinders binds = collect_binds binds []
508
509 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
510 collectHsBindListBinders = foldr (collect_bind . unLoc) []
511
512 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
513 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
514
515 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
516 -- Used exclusively for the bindings of an instance decl which are all FunBinds
517 collectMethodBinders binds = foldrBag get [] binds
518   where
519     get (L _ (FunBind { fun_id = f })) fs = f : fs
520     get _                              fs = fs  
521        -- Someone else complains about non-FunBinds
522
523 ----------------- Statements --------------------------
524 collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
525 collectLStmtsBinders = concatMap collectLStmtBinders
526
527 collectStmtsBinders :: [StmtLR idL idR] -> [idL]
528 collectStmtsBinders = concatMap collectStmtBinders
529
530 collectLStmtBinders :: LStmtLR idL idR -> [idL]
531 collectLStmtBinders = collectStmtBinders . unLoc
532
533 collectStmtBinders :: StmtLR idL idR -> [idL]
534   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
535 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
536 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
537 collectStmtBinders (ExprStmt {})        = []
538 collectStmtBinders (LastStmt {})        = []
539 collectStmtBinders (ParStmt xs _ _ _)   = collectLStmtsBinders
540                                         $ concatMap fst xs
541 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
542 collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
543
544
545 ----------------- Patterns --------------------------
546 collectPatBinders :: LPat a -> [a]
547 collectPatBinders pat = collect_lpat pat []
548
549 collectPatsBinders :: [LPat a] -> [a]
550 collectPatsBinders pats = foldr collect_lpat [] pats
551
552 -------------
553 collect_lpat :: LPat name -> [name] -> [name]
554 collect_lpat (L _ pat) bndrs
555   = go pat
556   where
557     go (VarPat var)               = var : bndrs
558     go (WildPat _)                = bndrs
559     go (LazyPat pat)              = collect_lpat pat bndrs
560     go (BangPat pat)              = collect_lpat pat bndrs
561     go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
562     go (ViewPat _ pat _)          = collect_lpat pat bndrs
563     go (ParPat  pat)              = collect_lpat pat bndrs
564                                   
565     go (ListPat pats _)           = foldr collect_lpat bndrs pats
566     go (PArrPat pats _)           = foldr collect_lpat bndrs pats
567     go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats
568                                   
569     go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
570     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
571         -- See Note [Dictionary binders in ConPatOut]
572     go (LitPat _)                 = bndrs
573     go (NPat _ _ _)               = bndrs
574     go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
575                                   
576     go (SigPatIn pat _)           = collect_lpat pat bndrs
577     go (SigPatOut pat _)          = collect_lpat pat bndrs
578     go (QuasiQuotePat _)          = bndrs
579     go (CoPat _ pat _)            = go pat
580 \end{code}
581
582 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
583 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
584 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
585 of a ConPatOut pattern.  For most calls it doesn't matter, because
586 it's pre-typechecker and there are no ConPatOuts.  But it does matter
587 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
588 collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
589 we want to generate bindings for x,y but not for dictionaries bound by
590 C.  (The type checker ensures they would not be used.)
591
592 Desugaring of arrow case expressions needs these bindings (see DsArrows
593 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
594 own pat-binder-collector:
595
596 Here's the problem.  Consider
597
598 data T a where
599    C :: Num a => a -> Int -> T a
600
601 f ~(C (n+1) m) = (n,m)
602
603 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
604 and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
605 variables bound by the lazy pattern are n,m, *not* the dictionary d.
606 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
607
608 \begin{code}
609 hsGroupBinders :: HsGroup Name -> [Name]
610 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
611                           hs_instds = inst_decls, hs_fords = foreign_decls })
612 -- Collect the binders of a Group
613   =  collectHsValBinders val_decls
614   ++ hsTyClDeclsBinders tycl_decls inst_decls
615   ++ hsForeignDeclsBinders foreign_decls
616
617 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
618 hsForeignDeclsBinders foreign_decls
619   = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
620
621 hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
622 -- We need to look at instance declarations too, 
623 -- because their associated types may bind data constructors
624 hsTyClDeclsBinders tycl_decls inst_decls
625   = [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls
626        , L _ n <- hsLTyClDeclBinders d]
627
628 hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
629 -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
630 -- The first one is guaranteed to be the name of the decl. For record fields
631 -- mentioned in multiple constructors, the SrcLoc will be from the first
632 -- occurence.  We use the equality to filter out duplicate field names
633 hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
634
635 hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
636 hsTyClDeclBinders (TyFamily    {tcdLName = name}) = [name]
637 hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
638
639 hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
640   = cls_name : 
641     concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
642
643 hsTyClDeclBinders (TySynonym   {tcdLName = name, tcdTyPats = mb_pats }) 
644   | isJust mb_pats = []
645   | otherwise      = [name]
646   -- See Note [Binders in family instances]
647
648 hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })
649   | isJust mb_pats = hsConDeclsBinders cons
650   | otherwise      = tc_name : hsConDeclsBinders cons
651   -- See Note [Binders in family instances]
652
653 hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
654   -- See hsTyClDeclBinders for what this does
655   -- The function is boringly complicated because of the records
656   -- And since we only have equality, we have to be a little careful
657 hsConDeclsBinders cons
658   = snd (foldl do_one ([], []) cons)
659   where
660     do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
661         = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
662         where
663           new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
664                                (map cd_fld_name flds)
665
666     do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
667         = (flds_seen, lname:acc)
668 \end{code}
669
670 Note [Binders in family instances]
671 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
672 In a type or data family instance declaration, the type 
673 constructor is an *occurrence* not a binding site
674     type instance T Int = Int -> Int   -- No binders
675     data instance S Bool = S1 | S2     -- Binders are S1,S2
676
677
678 %************************************************************************
679 %*                                                                      *
680         Collecting binders the user did not write
681 %*                                                                      *
682 %************************************************************************
683
684 The job of this family of functions is to run through binding sites and find the set of all Names
685 that were defined "implicitly", without being explicitly written by the user.
686
687 The main purpose is to find names introduced by record wildcards so that we can avoid
688 warning the user when they don't use those names (#4404)
689
690 \begin{code}
691 lStmtsImplicits :: [LStmtLR Name idR] -> NameSet
692 lStmtsImplicits = hs_lstmts
693   where
694     hs_lstmts :: [LStmtLR Name idR] -> NameSet
695     hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet
696     
697     hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
698     hs_stmt (LetStmt binds)      = hs_local_binds binds
699     hs_stmt (ExprStmt {})        = emptyNameSet
700     hs_stmt (LastStmt {})        = emptyNameSet
701     hs_stmt (ParStmt xs _ _ _)   = hs_lstmts $ concatMap fst xs
702     
703     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
704     hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
705     
706     hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
707     hs_local_binds (HsIPBinds _)         = emptyNameSet
708     hs_local_binds EmptyLocalBinds       = emptyNameSet
709
710 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
711 hsValBindsImplicits (ValBindsOut binds _)
712   = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds
713 hsValBindsImplicits (ValBindsIn binds _) 
714   = lhsBindsImplicits binds
715
716 lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
717 lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet
718   where
719     lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat
720     lhs_bind _ = emptyNameSet
721
722 lPatImplicits :: LPat Name -> NameSet
723 lPatImplicits = hs_lpat
724   where
725     hs_lpat (L _ pat) = hs_pat pat
726     
727     hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet
728     
729     hs_pat (LazyPat pat)       = hs_lpat pat
730     hs_pat (BangPat pat)       = hs_lpat pat
731     hs_pat (AsPat _ pat)       = hs_lpat pat
732     hs_pat (ViewPat _ pat _)   = hs_lpat pat
733     hs_pat (ParPat  pat)       = hs_lpat pat
734     hs_pat (ListPat pats _)    = hs_lpats pats
735     hs_pat (PArrPat pats _)    = hs_lpats pats
736     hs_pat (TuplePat pats _ _) = hs_lpats pats
737
738     hs_pat (SigPatIn pat _)  = hs_lpat pat
739     hs_pat (SigPatOut pat _) = hs_lpat pat
740     hs_pat (CoPat _ pat _)   = hs_pat pat
741     
742     hs_pat (ConPatIn _ ps)           = details ps
743     hs_pat (ConPatOut {pat_args=ps}) = details ps
744     
745     hs_pat _ = emptyNameSet
746     
747     details (PrefixCon ps)   = hs_lpats ps
748     details (RecCon fs)      = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit)
749       where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
750                                                     | (i, fld) <- [0..] `zip` rec_flds fs
751                                                     , let pat = hsRecFieldArg fld
752                                                           pat_explicit = maybe True (i<) (rec_dotdot fs)]
753     details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2
754 \end{code}
755
756
757 %************************************************************************
758 %*                                                                      *
759         Collecting type signatures from patterns
760 %*                                                                      *
761 %************************************************************************
762
763 \begin{code}
764 collectSigTysFromPats :: [InPat name] -> [HsBndrSig (LHsType name)]
765 collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
766
767 collectSigTysFromPat :: InPat name -> [HsBndrSig (LHsType name)]
768 collectSigTysFromPat pat = collect_sig_lpat pat []
769
770 collect_sig_lpat :: InPat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)]
771 collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
772
773 collect_sig_pat :: Pat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)]
774 collect_sig_pat (SigPatIn pat ty)   acc = collect_sig_lpat pat (ty:acc)
775
776 collect_sig_pat (LazyPat pat)       acc = collect_sig_lpat pat acc
777 collect_sig_pat (BangPat pat)       acc = collect_sig_lpat pat acc
778 collect_sig_pat (AsPat _ pat)       acc = collect_sig_lpat pat acc
779 collect_sig_pat (ParPat  pat)       acc = collect_sig_lpat pat acc
780 collect_sig_pat (ListPat pats _)    acc = foldr collect_sig_lpat acc pats
781 collect_sig_pat (PArrPat pats _)    acc = foldr collect_sig_lpat acc pats
782 collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
783 collect_sig_pat (ConPatIn _ ps)     acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
784 collect_sig_pat _                   acc = acc       -- Literals, vars, wildcard
785 \end{code}