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