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