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