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,
66 -- Collecting implicit binders
67 lStmtsImplicits, hsValBindsImplicits, lPatImplicits
95 %************************************************************************
97 Some useful helpers for constructing syntax
99 %************************************************************************
101 These functions attempt to construct a not-completely-useless SrcSpan
102 from their components, compared with the nl* functions below which
103 just attach noSrcSpan to everything.
106 mkHsPar :: LHsExpr id -> LHsExpr id
107 mkHsPar e = L (getLoc e) (HsPar e)
109 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
110 mkSimpleMatch pats rhs
112 Match pats Nothing (unguardedGRHSs rhs)
116 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
118 unguardedGRHSs :: LHsExpr id -> GRHSs id
119 unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
121 unguardedRHS :: LHsExpr id -> [LGRHS id]
122 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
124 mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
125 mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
127 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
128 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
130 nlHsTyApp :: name -> [Type] -> LHsExpr name
131 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
133 mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
134 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
136 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
137 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
138 | otherwise = HsWrap co_fn e
140 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
141 mkHsWrapCoI (IdCo _) e = e
142 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
144 mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
145 mkLHsWrapCoI (IdCo _) e = e
146 mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
148 coiToHsWrapper :: CoercionI -> HsWrapper
149 coiToHsWrapper (IdCo _) = idHsWrapper
150 coiToHsWrapper (ACo co) = WpCast co
152 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
153 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
154 | otherwise = CoPat co_fn p ty
156 mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
157 mkHsWrapPatCoI (IdCo _) pat _ = pat
158 mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
160 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
161 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
163 matches = mkMatchGroup [mkSimpleMatch pats body]
165 mkMatchGroup :: [LMatch id] -> MatchGroup id
166 mkMatchGroup matches = MatchGroup matches placeHolderType
168 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
169 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
171 mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
172 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
174 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
175 -- Used for constructing dictionary terms etc, so no locations
176 mkHsConApp data_con tys args
177 = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
179 mk_app f a = noLoc (HsApp f (noLoc a))
181 mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
182 -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
183 mkSimpleHsAlt pat expr
184 = mkSimpleMatch [pat] expr
186 -------------------------------
187 -- These are the bits of syntax that contain rebindable names
188 -- See RnEnv.lookupSyntaxName
190 mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
191 mkHsFractional :: Rational -> PostTcType -> HsOverLit id
192 mkHsIsString :: FastString -> PostTcType -> HsOverLit id
193 mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
195 mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
196 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
198 mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
199 mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
201 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
202 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
204 emptyRecStmt :: StmtLR idL idR
205 mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR
208 mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr
209 mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
210 mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr
212 noRebindableInfo :: Bool
213 noRebindableInfo = error "noRebindableInfo" -- Just another placeholder;
215 mkHsDo ctxt stmts body = HsDo ctxt stmts body noSyntaxExpr placeHolderType
217 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
218 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
220 mkNPat lit neg = NPat lit neg noSyntaxExpr
221 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
223 mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing noSyntaxExpr noSyntaxExpr
224 mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) noSyntaxExpr noSyntaxExpr
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
230 mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr
231 mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr
232 mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr
234 mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
235 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
237 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
238 , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
239 , recS_bind_fn = noSyntaxExpr
240 , recS_rec_rets = [] }
242 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
244 -------------------------------
245 --- A useful function for building @OpApps@. The operator is always a
246 -- variable, and we don't know the fixity yet.
247 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
248 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
250 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
251 mkHsSplice e = HsSplice unqualSplice e
253 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
254 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
256 unqualSplice :: RdrName
257 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
258 -- A name (uniquified later) to
259 -- identify the splice
261 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
262 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
264 unqualQuasiQuote :: RdrName
265 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
266 -- A name (uniquified later) to
267 -- identify the quasi-quote
269 mkHsString :: String -> HsLit
270 mkHsString s = HsString (mkFastString s)
273 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
274 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
278 %************************************************************************
280 Constructing syntax with no location info
282 %************************************************************************
285 nlHsVar :: id -> LHsExpr id
286 nlHsVar n = noLoc (HsVar n)
288 nlHsLit :: HsLit -> LHsExpr id
289 nlHsLit n = noLoc (HsLit n)
291 nlVarPat :: id -> LPat id
292 nlVarPat n = noLoc (VarPat n)
294 nlLitPat :: HsLit -> LPat id
295 nlLitPat l = noLoc (LitPat l)
297 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
298 nlHsApp f x = noLoc (HsApp f x)
300 nlHsIntLit :: Integer -> LHsExpr id
301 nlHsIntLit n = noLoc (HsLit (HsInt n))
303 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
304 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
306 nlHsVarApps :: id -> [id] -> LHsExpr id
307 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
309 mk f a = HsApp (noLoc f) (noLoc a)
311 nlConVarPat :: id -> [id] -> LPat id
312 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
314 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
315 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
317 nlConPat :: id -> [LPat id] -> LPat id
318 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
320 nlNullaryConPat :: id -> LPat id
321 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
323 nlWildConPat :: DataCon -> LPat RdrName
324 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
325 (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
328 nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
330 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
331 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
333 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
334 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
336 nlHsLam :: LMatch id -> LHsExpr id
337 nlHsPar :: LHsExpr id -> LHsExpr id
338 nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
339 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
340 nlList :: [LHsExpr id] -> LHsExpr id
342 nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
343 nlHsPar e = noLoc (HsPar e)
344 nlHsIf cond true false = noLoc (mkHsIf cond true false)
345 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
346 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
348 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
349 nlHsTyVar :: name -> LHsType name
350 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
352 nlHsAppTy f t = noLoc (HsAppTy f t)
353 nlHsTyVar x = noLoc (HsTyVar x)
354 nlHsFunTy a b = noLoc (HsFunTy a b)
356 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
357 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
360 Tuples. All these functions are *pre-typechecker* because they lack
364 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
365 -- Makes a pre-typechecker boxed tuple, deals with 1 case
366 mkLHsTupleExpr [e] = e
367 mkLHsTupleExpr es = noLoc $ ExplicitTuple (map Present es) Boxed
369 mkLHsVarTuple :: [a] -> LHsExpr a
370 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
372 nlTuplePat :: [LPat id] -> Boxity -> LPat id
373 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
375 missingTupArg :: HsTupArg a
376 missingTupArg = Missing placeHolderType
379 %************************************************************************
381 Bindings; with a location at the top
383 %************************************************************************
386 mkFunBind :: Located id -> [LMatch id] -> HsBind id
387 -- Not infix, with place holders for coercion and free vars
388 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
389 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
393 mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
394 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
396 mkVarBind :: id -> LHsExpr id -> LHsBind id
397 mkVarBind var rhs = L (getLoc rhs) $
398 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
401 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
402 -> LHsExpr id -> LHsBind id
404 mk_easy_FunBind loc fun pats expr
405 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
408 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
409 mkMatch pats expr binds
410 = noLoc (Match (map paren pats) Nothing
411 (GRHSs (unguardedRHS expr) binds))
413 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
418 %************************************************************************
422 %************************************************************************
424 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
432 it should return [x, y, f, a, b] (remember, order important).
434 Note [Collect binders only after renaming]
435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
436 These functions should only be used on HsSyn *after* the renamer,
437 to return a [Name] or [Id]. Before renaming the record punning
438 and wild-card mechanism makes it hard to know what is bound.
439 So these functions should not be applied to (HsSyn RdrName)
442 ----------------- Bindings --------------------------
443 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
444 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
445 collectLocalBinders (HsIPBinds _) = []
446 collectLocalBinders EmptyLocalBinds = []
448 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
449 collectHsValBinders (ValBindsIn binds _) = collectHsBindsBinders binds
450 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
452 collect_one (_,binds) acc = collect_binds binds acc
454 collectHsBindBinders :: HsBindLR idL idR -> [idL]
455 collectHsBindBinders b = collect_bind b []
457 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
458 collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc
459 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
460 collect_bind (VarBind { var_id = f }) acc = f : acc
461 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
462 = [dp | (_,dp,_,_) <- dbinds] ++ acc
463 -- ++ foldr collect_bind acc binds
464 -- I don't think we want the binders from the nested binds
465 -- The only time we collect binders from a typechecked
466 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
468 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
469 collectHsBindsBinders binds = collect_binds binds []
471 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
472 collectHsBindListBinders = foldr (collect_bind . unLoc) []
474 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
475 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
477 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
478 -- Used exclusively for the bindings of an instance decl which are all FunBinds
479 collectMethodBinders binds = foldrBag get [] binds
481 get (L _ (FunBind { fun_id = f })) fs = f : fs
483 -- Someone else complains about non-FunBinds
485 ----------------- Statements --------------------------
486 collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
487 collectLStmtsBinders = concatMap collectLStmtBinders
489 collectStmtsBinders :: [StmtLR idL idR] -> [idL]
490 collectStmtsBinders = concatMap collectStmtBinders
492 collectLStmtBinders :: LStmtLR idL idR -> [idL]
493 collectLStmtBinders = collectStmtBinders . unLoc
495 collectStmtBinders :: StmtLR idL idR -> [idL]
496 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
497 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
498 collectStmtBinders (LetStmt binds) = collectLocalBinders binds
499 collectStmtBinders (ExprStmt _ _ _ _) = []
500 collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
502 collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts
503 collectStmtBinders (GroupStmt stmts _ _ _ _ _ _) = collectLStmtsBinders stmts
504 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
507 ----------------- Patterns --------------------------
508 collectPatBinders :: LPat a -> [a]
509 collectPatBinders pat = collect_lpat pat []
511 collectPatsBinders :: [LPat a] -> [a]
512 collectPatsBinders pats = foldr collect_lpat [] pats
515 collect_lpat :: LPat name -> [name] -> [name]
516 collect_lpat (L _ pat) bndrs
519 go (VarPat var) = var : bndrs
520 go (WildPat _) = bndrs
521 go (LazyPat pat) = collect_lpat pat bndrs
522 go (BangPat pat) = collect_lpat pat bndrs
523 go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
524 go (ViewPat _ pat _) = collect_lpat pat bndrs
525 go (ParPat pat) = collect_lpat pat bndrs
527 go (ListPat pats _) = foldr collect_lpat bndrs pats
528 go (PArrPat pats _) = foldr collect_lpat bndrs pats
529 go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
531 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
532 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
533 -- See Note [Dictionary binders in ConPatOut]
534 go (LitPat _) = bndrs
535 go (NPat _ _ _) = bndrs
536 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
538 go (SigPatIn pat _) = collect_lpat pat bndrs
539 go (SigPatOut pat _) = collect_lpat pat bndrs
540 go (QuasiQuotePat _) = bndrs
541 go (TypePat _) = bndrs
542 go (CoPat _ pat _) = go pat
545 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
546 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
547 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
548 of a ConPatOut pattern. For most calls it doesn't matter, because
549 it's pre-typechecker and there are no ConPatOuts. But it does matter
550 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
551 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
552 we want to generate bindings for x,y but not for dictionaries bound by
553 C. (The type checker ensures they would not be used.)
555 Desugaring of arrow case expressions needs these bindings (see DsArrows
556 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
557 own pat-binder-collector:
559 Here's the problem. Consider
562 C :: Num a => a -> Int -> T a
564 f ~(C (n+1) m) = (n,m)
566 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
567 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
568 variables bound by the lazy pattern are n,m, *not* the dictionary d.
569 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
572 hsGroupBinders :: HsGroup Name -> [Name]
573 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
574 hs_instds = inst_decls, hs_fords = foreign_decls })
575 -- Collect the binders of a Group
576 = collectHsValBinders val_decls
577 ++ hsTyClDeclsBinders tycl_decls inst_decls
578 ++ hsForeignDeclsBinders foreign_decls
580 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
581 hsForeignDeclsBinders foreign_decls
582 = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
584 hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
585 hsTyClDeclsBinders tycl_decls inst_decls
586 = [n | d <- instDeclATs inst_decls ++ concat tycl_decls
587 , L _ n <- hsTyClDeclBinders d]
589 hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
590 -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
591 -- The first one is guaranteed to be the name of the decl. For record fields
592 -- mentioned in multiple constructors, the SrcLoc will be from the first
593 -- occurence. We use the equality to filter out duplicate field names
595 hsTyClDeclBinders (L _ (TyFamily {tcdLName = name})) = [name]
596 hsTyClDeclBinders (L _ (TySynonym {tcdLName = name})) = [name]
597 hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
599 hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
601 concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs]
603 hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons}))
604 = tc_name : hsConDeclsBinders cons
606 hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
607 -- See hsTyClDeclBinders for what this does
608 -- The function is boringly complicated because of the records
609 -- And since we only have equality, we have to be a little careful
610 hsConDeclsBinders cons
611 = snd (foldl do_one ([], []) cons)
613 do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
614 = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
616 new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
617 (map cd_fld_name flds)
619 do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
620 = (flds_seen, lname:acc)
624 %************************************************************************
626 Collecting binders the user did not write
628 %************************************************************************
630 The job of this family of functions is to run through binding sites and find the set of all Names
631 that were defined "implicitly", without being explicitly written by the user.
633 The main purpose is to find names introduced by record wildcards so that we can avoid
634 warning the user when they don't use those names (#4404)
637 lStmtsImplicits :: [LStmtLR Name idR] -> NameSet
638 lStmtsImplicits = hs_lstmts
640 hs_lstmts :: [LStmtLR Name idR] -> NameSet
641 hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet
643 hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
644 hs_stmt (LetStmt binds) = hs_local_binds binds
645 hs_stmt (ExprStmt _ _ _ _) = emptyNameSet
646 hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs
648 hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts
649 hs_stmt (GroupStmt stmts _ _ _ _ _ _) = hs_lstmts stmts
650 hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
652 hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
653 hs_local_binds (HsIPBinds _) = emptyNameSet
654 hs_local_binds EmptyLocalBinds = emptyNameSet
656 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
657 hsValBindsImplicits (ValBindsOut binds _)
658 = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds]
660 hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
661 hs_bind _ = emptyNameSet
662 hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty
664 lPatImplicits :: LPat Name -> NameSet
665 lPatImplicits = hs_lpat
667 hs_lpat (L _ pat) = hs_pat pat
669 hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet
671 hs_pat (LazyPat pat) = hs_lpat pat
672 hs_pat (BangPat pat) = hs_lpat pat
673 hs_pat (AsPat _ pat) = hs_lpat pat
674 hs_pat (ViewPat _ pat _) = hs_lpat pat
675 hs_pat (ParPat pat) = hs_lpat pat
676 hs_pat (ListPat pats _) = hs_lpats pats
677 hs_pat (PArrPat pats _) = hs_lpats pats
678 hs_pat (TuplePat pats _ _) = hs_lpats pats
680 hs_pat (SigPatIn pat _) = hs_lpat pat
681 hs_pat (SigPatOut pat _) = hs_lpat pat
682 hs_pat (CoPat _ pat _) = hs_pat pat
684 hs_pat (ConPatIn _ ps) = details ps
685 hs_pat (ConPatOut {pat_args=ps}) = details ps
687 hs_pat _ = emptyNameSet
689 details (PrefixCon ps) = hs_lpats ps
690 details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit)
691 where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
692 | (i, fld) <- [0..] `zip` rec_flds fs
693 , let pat = hsRecFieldArg fld
694 pat_explicit = maybe True (i<) (rec_dotdot fs)]
695 details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2
699 %************************************************************************
701 Collecting type signatures from patterns
703 %************************************************************************
706 collectSigTysFromPats :: [InPat name] -> [LHsType name]
707 collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
709 collectSigTysFromPat :: InPat name -> [LHsType name]
710 collectSigTysFromPat pat = collect_sig_lpat pat []
712 collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
713 collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
715 collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
716 collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
717 collect_sig_pat (TypePat ty) acc = ty:acc
719 collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc
720 collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc
721 collect_sig_pat (AsPat _ pat) acc = collect_sig_lpat pat acc
722 collect_sig_pat (ParPat pat) acc = collect_sig_lpat pat acc
723 collect_sig_pat (ListPat pats _) acc = foldr collect_sig_lpat acc pats
724 collect_sig_pat (PArrPat pats _) acc = foldr collect_sig_lpat acc pats
725 collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
726 collect_sig_pat (ConPatIn _ ps) acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
727 collect_sig_pat _ acc = acc -- Literals, vars, wildcard