3 % (c) The University of Glasgow, 1992-2006
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:
10 Parameterised by Module
11 ---------------- -------------
12 RdrName parser/RdrHsSyn
19 mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
20 mkSimpleMatch, unguardedGRHSs, unguardedRHS,
21 mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
22 mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
23 coiToHsWrapper, mkHsLams, mkHsDictLet,
24 mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
26 nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
27 nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
28 mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
31 mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
34 mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
37 mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
38 nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat,
41 mkHsAppTy, userHsTyVarBndrs,
42 nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
45 mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
46 mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
47 emptyRecStmt, mkRecStmt,
50 unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
56 collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
57 collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
58 collectPatBinders, collectPatsBinders,
59 collectLStmtsBinders, collectStmtsBinders,
60 collectLStmtBinders, collectStmtBinders,
61 collectSigTysFromPats, collectSigTysFromPat,
63 hsTyClDeclBinders, hsTyClDeclsBinders,
64 hsForeignDeclsBinders, hsGroupBinders
89 %************************************************************************
91 Some useful helpers for constructing syntax
93 %************************************************************************
95 These functions attempt to construct a not-completely-useless SrcSpan
96 from their components, compared with the nl* functions below which
97 just attach noSrcSpan to everything.
100 mkHsPar :: LHsExpr id -> LHsExpr id
101 mkHsPar e = L (getLoc e) (HsPar e)
103 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
104 mkSimpleMatch pats rhs
106 Match pats Nothing (unguardedGRHSs rhs)
110 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
112 unguardedGRHSs :: LHsExpr id -> GRHSs id
113 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
115 unguardedRHS :: LHsExpr id -> [LGRHS id]
116 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
118 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
119 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
121 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
122 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
124 nlHsTyApp :: name -> [Type] -> LHsExpr name
125 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
127 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
128 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
130 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
131 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
132 | otherwise = HsWrap co_fn e
134 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
135 mkHsWrapCoI (IdCo _) e = e
136 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
138 mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
139 mkLHsWrapCoI (IdCo _) e = e
140 mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
142 coiToHsWrapper :: CoercionI -> HsWrapper
143 coiToHsWrapper (IdCo _) = idHsWrapper
144 coiToHsWrapper (ACo co) = WpCast co
146 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
147 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
148 | otherwise = CoPat co_fn p ty
150 mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
151 mkHsWrapPatCoI (IdCo _) pat _ = pat
152 mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
154 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
155 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
157 matches = mkMatchGroup [mkSimpleMatch pats body]
159 mkMatchGroup :: [LMatch id] -> MatchGroup id
160 mkMatchGroup matches = MatchGroup matches placeHolderType
162 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
163 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
165 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
166 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
168 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
169 -- Used for constructing dictionary terms etc, so no locations
170 mkHsConApp data_con tys args
171 = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
173 mk_app f a = noLoc (HsApp f (noLoc a))
175 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
176 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
177 mkSimpleHsAlt pat expr
178 = mkSimpleMatch [pat] expr
180 -------------------------------
181 -- These are the bits of syntax that contain rebindable names
182 -- See RnEnv.lookupSyntaxName
184 mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
185 mkHsFractional :: Rational -> PostTcType -> HsOverLit id
186 mkHsIsString :: FastString -> PostTcType -> HsOverLit id
187 mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
189 mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
190 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
192 mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
193 mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
195 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
196 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
198 emptyRecStmt :: StmtLR idL idR
199 mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR
202 mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr
203 mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
204 mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr
206 noRebindableInfo :: Bool
207 noRebindableInfo = error "noRebindableInfo" -- Just another placeholder;
209 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
211 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
212 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
214 mkNPat lit neg = NPat lit neg noSyntaxExpr
215 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
217 mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing
218 mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
220 mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
221 mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
222 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
224 mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr)
225 mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
226 mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)
228 mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
229 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
231 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
232 , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
233 , recS_bind_fn = noSyntaxExpr
234 , recS_rec_rets = [] }
236 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
238 -------------------------------
239 --- A useful function for building @OpApps@. The operator is always a
240 -- variable, and we don't know the fixity yet.
241 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
242 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
244 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
245 mkHsSplice e = HsSplice unqualSplice e
247 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
248 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
250 unqualSplice :: RdrName
251 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
252 -- A name (uniquified later) to
253 -- identify the splice
255 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
256 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
258 unqualQuasiQuote :: RdrName
259 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
260 -- A name (uniquified later) to
261 -- identify the quasi-quote
263 mkHsString :: String -> HsLit
264 mkHsString s = HsString (mkFastString s)
267 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
268 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
272 %************************************************************************
274 Constructing syntax with no location info
276 %************************************************************************
279 nlHsVar :: id -> LHsExpr id
280 nlHsVar n = noLoc (HsVar n)
282 nlHsLit :: HsLit -> LHsExpr id
283 nlHsLit n = noLoc (HsLit n)
285 nlVarPat :: id -> LPat id
286 nlVarPat n = noLoc (VarPat n)
288 nlLitPat :: HsLit -> LPat id
289 nlLitPat l = noLoc (LitPat l)
291 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
292 nlHsApp f x = noLoc (HsApp f x)
294 nlHsIntLit :: Integer -> LHsExpr id
295 nlHsIntLit n = noLoc (HsLit (HsInt n))
297 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
298 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
300 nlHsVarApps :: id -> [id] -> LHsExpr id
301 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
303 mk f a = HsApp (noLoc f) (noLoc a)
305 nlConVarPat :: id -> [id] -> LPat id
306 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
308 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
309 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
311 nlConPat :: id -> [LPat id] -> LPat id
312 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
314 nlNullaryConPat :: id -> LPat id
315 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
317 nlWildConPat :: DataCon -> LPat RdrName
318 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
319 (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
322 nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
324 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
325 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
327 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
328 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
330 nlHsLam :: LMatch id -> LHsExpr id
331 nlHsPar :: LHsExpr id -> LHsExpr id
332 nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
333 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
334 nlList :: [LHsExpr id] -> LHsExpr id
336 nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
337 nlHsPar e = noLoc (HsPar e)
338 nlHsIf cond true false = noLoc (mkHsIf cond true false)
339 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
340 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
342 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
343 nlHsTyVar :: name -> LHsType name
344 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
346 nlHsAppTy f t = noLoc (HsAppTy f t)
347 nlHsTyVar x = noLoc (HsTyVar x)
348 nlHsFunTy a b = noLoc (HsFunTy a b)
350 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
351 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
354 Tuples. All these functions are *pre-typechecker* because they lack
358 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
359 -- Makes a pre-typechecker boxed tuple, deals with 1 case
360 mkLHsTupleExpr [e] = e
361 mkLHsTupleExpr es = noLoc $ ExplicitTuple (map Present es) Boxed
363 mkLHsVarTuple :: [a] -> LHsExpr a
364 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
366 nlTuplePat :: [LPat id] -> Boxity -> LPat id
367 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
369 missingTupArg :: HsTupArg a
370 missingTupArg = Missing placeHolderType
373 %************************************************************************
375 Bindings; with a location at the top
377 %************************************************************************
380 mkFunBind :: Located id -> [LMatch id] -> HsBind id
381 -- Not infix, with place holders for coercion and free vars
382 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
383 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
387 mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
388 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
390 mkVarBind :: id -> LHsExpr id -> LHsBind id
391 mkVarBind var rhs = L (getLoc rhs) $
392 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
395 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
396 -> LHsExpr id -> LHsBind id
398 mk_easy_FunBind loc fun pats expr
399 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
402 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
403 mkMatch pats expr binds
404 = noLoc (Match (map paren pats) Nothing
405 (GRHSs (unguardedRHS expr) binds))
407 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
412 %************************************************************************
416 %************************************************************************
418 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
426 it should return [x, y, f, a, b] (remember, order important).
428 Note [Collect binders only after renaming]
429 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
430 These functions should only be used on HsSyn *after* the renamer,
431 to return a [Name] or [Id]. Before renaming the record punning
432 and wild-card mechanism makes it hard to know what is bound.
433 So these functions should not be applied to (HsSyn RdrName)
436 ----------------- Bindings --------------------------
437 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
438 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
439 collectLocalBinders (HsIPBinds _) = []
440 collectLocalBinders EmptyLocalBinds = []
442 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
443 collectHsValBinders (ValBindsIn binds _) = collectHsBindsBinders binds
444 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
446 collect_one (_,binds) acc = collect_binds binds acc
448 collectHsBindBinders :: HsBindLR idL idR -> [idL]
449 collectHsBindBinders b = collect_bind b []
451 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
452 collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc
453 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
454 collect_bind (VarBind { var_id = f }) acc = f : acc
455 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
456 = [dp | (_,dp,_,_) <- dbinds] ++ acc
457 -- ++ foldr collect_bind acc binds
458 -- I don't think we want the binders from the nested binds
459 -- The only time we collect binders from a typechecked
460 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
462 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
463 collectHsBindsBinders binds = collect_binds binds []
465 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
466 collectHsBindListBinders = foldr (collect_bind . unLoc) []
468 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
469 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
471 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
472 -- Used exclusively for the bindings of an instance decl which are all FunBinds
473 collectMethodBinders binds = foldrBag get [] binds
475 get (L _ (FunBind { fun_id = f })) fs = f : fs
477 -- Someone else complains about non-FunBinds
479 ----------------- Statements --------------------------
480 collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
481 collectLStmtsBinders = concatMap collectLStmtBinders
483 collectStmtsBinders :: [StmtLR idL idR] -> [idL]
484 collectStmtsBinders = concatMap collectStmtBinders
486 collectLStmtBinders :: LStmtLR idL idR -> [idL]
487 collectLStmtBinders = collectStmtBinders . unLoc
489 collectStmtBinders :: StmtLR idL idR -> [idL]
490 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
491 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
492 collectStmtBinders (LetStmt binds) = collectLocalBinders binds
493 collectStmtBinders (ExprStmt _ _ _) = []
494 collectStmtBinders (ParStmt xs) = collectLStmtsBinders
496 collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts
497 collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts
498 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
501 ----------------- Patterns --------------------------
502 collectPatBinders :: LPat a -> [a]
503 collectPatBinders pat = collect_lpat pat []
505 collectPatsBinders :: [LPat a] -> [a]
506 collectPatsBinders pats = foldr collect_lpat [] pats
509 collect_lpat :: LPat name -> [name] -> [name]
510 collect_lpat (L _ pat) bndrs
513 go (VarPat var) = var : bndrs
514 go (WildPat _) = bndrs
515 go (LazyPat pat) = collect_lpat pat bndrs
516 go (BangPat pat) = collect_lpat pat bndrs
517 go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
518 go (ViewPat _ pat _) = collect_lpat pat bndrs
519 go (ParPat pat) = collect_lpat pat bndrs
521 go (ListPat pats _) = foldr collect_lpat bndrs pats
522 go (PArrPat pats _) = foldr collect_lpat bndrs pats
523 go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
525 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
526 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
527 -- See Note [Dictionary binders in ConPatOut]
528 go (LitPat _) = bndrs
529 go (NPat _ _ _) = bndrs
530 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
532 go (SigPatIn pat _) = collect_lpat pat bndrs
533 go (SigPatOut pat _) = collect_lpat pat bndrs
534 go (QuasiQuotePat _) = bndrs
535 go (TypePat _) = bndrs
536 go (CoPat _ pat _) = go pat
539 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
540 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
541 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
542 of a ConPatOut pattern. For most calls it doesn't matter, because
543 it's pre-typechecker and there are no ConPatOuts. But it does matter
544 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
545 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
546 we want to generate bindings for x,y but not for dictionaries bound by
547 C. (The type checker ensures they would not be used.)
549 Desugaring of arrow case expressions needs these bindings (see DsArrows
550 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
551 own pat-binder-collector:
553 Here's the problem. Consider
556 C :: Num a => a -> Int -> T a
558 f ~(C (n+1) m) = (n,m)
560 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
561 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
562 variables bound by the lazy pattern are n,m, *not* the dictionary d.
563 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
566 hsGroupBinders :: HsGroup Name -> [Name]
567 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
568 hs_instds = inst_decls, hs_fords = foreign_decls })
569 -- Collect the binders of a Group
570 = collectHsValBinders val_decls
571 ++ hsTyClDeclsBinders tycl_decls inst_decls
572 ++ hsForeignDeclsBinders foreign_decls
574 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
575 hsForeignDeclsBinders foreign_decls
576 = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
578 hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
579 hsTyClDeclsBinders tycl_decls inst_decls
580 = [n | d <- instDeclATs inst_decls ++ concat tycl_decls
581 , L _ n <- hsTyClDeclBinders d]
583 hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
584 -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
585 -- The first one is guaranteed to be the name of the decl. For record fields
586 -- mentioned in multiple constructors, the SrcLoc will be from the first
587 -- occurence. We use the equality to filter out duplicate field names
589 hsTyClDeclBinders (L _ (TyFamily {tcdLName = name})) = [name]
590 hsTyClDeclBinders (L _ (TySynonym {tcdLName = name})) = [name]
591 hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
593 hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
595 concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs]
597 hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons}))
598 = tc_name : hsConDeclsBinders cons
600 hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
601 -- See hsTyClDeclBinders for what this does
602 -- The function is boringly complicated because of the records
603 -- And since we only have equality, we have to be a little careful
604 hsConDeclsBinders cons
605 = snd (foldl do_one ([], []) cons)
607 do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
608 = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
610 new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
611 (map cd_fld_name flds)
613 do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
614 = (flds_seen, lname:acc)
618 %************************************************************************
620 Collecting type signatures from patterns
622 %************************************************************************
625 collectSigTysFromPats :: [InPat name] -> [LHsType name]
626 collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
628 collectSigTysFromPat :: InPat name -> [LHsType name]
629 collectSigTysFromPat pat = collect_sig_lpat pat []
631 collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
632 collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
634 collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
635 collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
636 collect_sig_pat (TypePat ty) acc = ty:acc
638 collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc
639 collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc
640 collect_sig_pat (AsPat _ pat) acc = collect_sig_lpat pat acc
641 collect_sig_pat (ParPat pat) acc = collect_sig_lpat pat acc
642 collect_sig_pat (ListPat pats _) acc = foldr collect_sig_lpat acc pats
643 collect_sig_pat (PArrPat pats _) acc = foldr collect_sig_lpat acc pats
644 collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
645 collect_sig_pat (ConPatIn _ ps) acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
646 collect_sig_pat _ acc = acc -- Literals, vars, wildcard