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, mkHsComp, 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, mkLastStmt,
46 emptyGroupStmt, 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] -> HsExpr id
194 mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
196 mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
197 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
199 mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
200 mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
202 mkLastStmt :: LHsExpr idR -> StmtLR idL idR
203 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
204 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
206 emptyRecStmt :: StmtLR idL idR
207 mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR
210 mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr
211 mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
212 mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr
214 noRebindableInfo :: Bool
215 noRebindableInfo = error "noRebindableInfo" -- Just another placeholder;
217 mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType
218 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
220 last_stmt = L (getLoc expr) $ mkLastStmt expr
222 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
223 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
225 mkNPat lit neg = NPat lit neg noSyntaxExpr
226 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
228 mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing noSyntaxExpr noSyntaxExpr
229 mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) noSyntaxExpr noSyntaxExpr
231 mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
232 mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
233 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
235 emptyGroupStmt :: StmtLR idL idR
236 emptyGroupStmt = GroupStmt { grpS_stmts = [], grpS_bndrs = [], grpS_explicit = False
237 , grpS_by = Nothing, grpS_using = noLoc noSyntaxExpr
238 , grpS_ret = noSyntaxExpr, grpS_bind = noSyntaxExpr
239 , grpS_fmap = noSyntaxExpr }
240 mkGroupUsingStmt ss u = emptyGroupStmt { grpS_stmts = ss, grpS_explicit = True, grpS_using = u }
241 mkGroupByStmt ss b = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b }
242 mkGroupByUsingStmt ss b u = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b
243 , grpS_explicit = True, grpS_using = u }
245 mkLastStmt expr = LastStmt expr noSyntaxExpr
246 mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
247 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
249 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
250 , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
251 , recS_bind_fn = noSyntaxExpr
252 , recS_rec_rets = [], recS_ret_ty = placeHolderType }
254 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
256 -------------------------------
257 --- A useful function for building @OpApps@. The operator is always a
258 -- variable, and we don't know the fixity yet.
259 mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
260 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
262 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
263 mkHsSplice e = HsSplice unqualSplice e
265 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
266 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
268 unqualSplice :: RdrName
269 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
270 -- A name (uniquified later) to
271 -- identify the splice
273 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
274 mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
276 unqualQuasiQuote :: RdrName
277 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
278 -- A name (uniquified later) to
279 -- identify the quasi-quote
281 mkHsString :: String -> HsLit
282 mkHsString s = HsString (mkFastString s)
285 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
286 userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
290 %************************************************************************
292 Constructing syntax with no location info
294 %************************************************************************
297 nlHsVar :: id -> LHsExpr id
298 nlHsVar n = noLoc (HsVar n)
300 nlHsLit :: HsLit -> LHsExpr id
301 nlHsLit n = noLoc (HsLit n)
303 nlVarPat :: id -> LPat id
304 nlVarPat n = noLoc (VarPat n)
306 nlLitPat :: HsLit -> LPat id
307 nlLitPat l = noLoc (LitPat l)
309 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
310 nlHsApp f x = noLoc (HsApp f x)
312 nlHsIntLit :: Integer -> LHsExpr id
313 nlHsIntLit n = noLoc (HsLit (HsInt n))
315 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
316 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
318 nlHsVarApps :: id -> [id] -> LHsExpr id
319 nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs))
321 mk f a = HsApp (noLoc f) (noLoc a)
323 nlConVarPat :: id -> [id] -> LPat id
324 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
326 nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
327 nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
329 nlConPat :: id -> [LPat id] -> LPat id
330 nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
332 nlNullaryConPat :: id -> LPat id
333 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
335 nlWildConPat :: DataCon -> LPat RdrName
336 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
337 (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
340 nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
342 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
343 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
345 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
346 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
348 nlHsLam :: LMatch id -> LHsExpr id
349 nlHsPar :: LHsExpr id -> LHsExpr id
350 nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
351 nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
352 nlList :: [LHsExpr id] -> LHsExpr id
354 nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
355 nlHsPar e = noLoc (HsPar e)
356 nlHsIf cond true false = noLoc (mkHsIf cond true false)
357 nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
358 nlList exprs = noLoc (ExplicitList placeHolderType exprs)
360 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
361 nlHsTyVar :: name -> LHsType name
362 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
364 nlHsAppTy f t = noLoc (HsAppTy f t)
365 nlHsTyVar x = noLoc (HsTyVar x)
366 nlHsFunTy a b = noLoc (HsFunTy a b)
368 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
369 nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
372 Tuples. All these functions are *pre-typechecker* because they lack
376 mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
377 -- Makes a pre-typechecker boxed tuple, deals with 1 case
378 mkLHsTupleExpr [e] = e
379 mkLHsTupleExpr es = noLoc $ ExplicitTuple (map Present es) Boxed
381 mkLHsVarTuple :: [a] -> LHsExpr a
382 mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
384 nlTuplePat :: [LPat id] -> Boxity -> LPat id
385 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
387 missingTupArg :: HsTupArg a
388 missingTupArg = Missing placeHolderType
391 %************************************************************************
393 Bindings; with a location at the top
395 %************************************************************************
398 mkFunBind :: Located id -> [LMatch id] -> HsBind id
399 -- Not infix, with place holders for coercion and free vars
400 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
401 fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
405 mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
406 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
408 mkVarBind :: id -> LHsExpr id -> LHsBind id
409 mkVarBind var rhs = L (getLoc rhs) $
410 VarBind { var_id = var, var_rhs = rhs, var_inline = False }
413 mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
414 -> LHsExpr id -> LHsBind id
416 mk_easy_FunBind loc fun pats expr
417 = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
420 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
421 mkMatch pats expr binds
422 = noLoc (Match (map paren pats) Nothing
423 (GRHSs (unguardedRHS expr) binds))
425 paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
430 %************************************************************************
434 %************************************************************************
436 Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.
444 it should return [x, y, f, a, b] (remember, order important).
446 Note [Collect binders only after renaming]
447 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
448 These functions should only be used on HsSyn *after* the renamer,
449 to return a [Name] or [Id]. Before renaming the record punning
450 and wild-card mechanism makes it hard to know what is bound.
451 So these functions should not be applied to (HsSyn RdrName)
454 ----------------- Bindings --------------------------
455 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
456 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
457 collectLocalBinders (HsIPBinds _) = []
458 collectLocalBinders EmptyLocalBinds = []
460 collectHsValBinders :: HsValBindsLR idL idR -> [idL]
461 collectHsValBinders (ValBindsIn binds _) = collectHsBindsBinders binds
462 collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
464 collect_one (_,binds) acc = collect_binds binds acc
466 collectHsBindBinders :: HsBindLR idL idR -> [idL]
467 collectHsBindBinders b = collect_bind b []
469 collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
470 collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc
471 collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
472 collect_bind (VarBind { var_id = f }) acc = f : acc
473 collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
474 = [dp | (_,dp,_,_) <- dbinds] ++ acc
475 -- ++ foldr collect_bind acc binds
476 -- I don't think we want the binders from the nested binds
477 -- The only time we collect binders from a typechecked
478 -- binding (hence see AbsBinds) is in zonking in TcHsSyn
480 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
481 collectHsBindsBinders binds = collect_binds binds []
483 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
484 collectHsBindListBinders = foldr (collect_bind . unLoc) []
486 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
487 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
489 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
490 -- Used exclusively for the bindings of an instance decl which are all FunBinds
491 collectMethodBinders binds = foldrBag get [] binds
493 get (L _ (FunBind { fun_id = f })) fs = f : fs
495 -- Someone else complains about non-FunBinds
497 ----------------- Statements --------------------------
498 collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
499 collectLStmtsBinders = concatMap collectLStmtBinders
501 collectStmtsBinders :: [StmtLR idL idR] -> [idL]
502 collectStmtsBinders = concatMap collectStmtBinders
504 collectLStmtBinders :: LStmtLR idL idR -> [idL]
505 collectLStmtBinders = collectStmtBinders . unLoc
507 collectStmtBinders :: StmtLR idL idR -> [idL]
508 -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
509 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
510 collectStmtBinders (LetStmt binds) = collectLocalBinders binds
511 collectStmtBinders (ExprStmt {}) = []
512 collectStmtBinders (LastStmt {}) = []
513 collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
515 collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts
516 collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts
517 collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
520 ----------------- Patterns --------------------------
521 collectPatBinders :: LPat a -> [a]
522 collectPatBinders pat = collect_lpat pat []
524 collectPatsBinders :: [LPat a] -> [a]
525 collectPatsBinders pats = foldr collect_lpat [] pats
528 collect_lpat :: LPat name -> [name] -> [name]
529 collect_lpat (L _ pat) bndrs
532 go (VarPat var) = var : bndrs
533 go (WildPat _) = bndrs
534 go (LazyPat pat) = collect_lpat pat bndrs
535 go (BangPat pat) = collect_lpat pat bndrs
536 go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs
537 go (ViewPat _ pat _) = collect_lpat pat bndrs
538 go (ParPat pat) = collect_lpat pat bndrs
540 go (ListPat pats _) = foldr collect_lpat bndrs pats
541 go (PArrPat pats _) = foldr collect_lpat bndrs pats
542 go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
544 go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
545 go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
546 -- See Note [Dictionary binders in ConPatOut]
547 go (LitPat _) = bndrs
548 go (NPat _ _ _) = bndrs
549 go (NPlusKPat (L _ n) _ _ _) = n : bndrs
551 go (SigPatIn pat _) = collect_lpat pat bndrs
552 go (SigPatOut pat _) = collect_lpat pat bndrs
553 go (QuasiQuotePat _) = bndrs
554 go (TypePat _) = bndrs
555 go (CoPat _ pat _) = go pat
558 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
559 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
560 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
561 of a ConPatOut pattern. For most calls it doesn't matter, because
562 it's pre-typechecker and there are no ConPatOuts. But it does matter
563 more in the desugarer; for example, DsUtils.mkSelectorBinds uses
564 collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
565 we want to generate bindings for x,y but not for dictionaries bound by
566 C. (The type checker ensures they would not be used.)
568 Desugaring of arrow case expressions needs these bindings (see DsArrows
569 and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
570 own pat-binder-collector:
572 Here's the problem. Consider
575 C :: Num a => a -> Int -> T a
577 f ~(C (n+1) m) = (n,m)
579 Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
580 and *also* uses that dictionary to match the (n+1) pattern. Yet, the
581 variables bound by the lazy pattern are n,m, *not* the dictionary d.
582 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
585 hsGroupBinders :: HsGroup Name -> [Name]
586 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
587 hs_instds = inst_decls, hs_fords = foreign_decls })
588 -- Collect the binders of a Group
589 = collectHsValBinders val_decls
590 ++ hsTyClDeclsBinders tycl_decls inst_decls
591 ++ hsForeignDeclsBinders foreign_decls
593 hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
594 hsForeignDeclsBinders foreign_decls
595 = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
597 hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
598 hsTyClDeclsBinders tycl_decls inst_decls
599 = [n | d <- instDeclATs inst_decls ++ concat tycl_decls
600 , L _ n <- hsTyClDeclBinders d]
602 hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
603 -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
604 -- The first one is guaranteed to be the name of the decl. For record fields
605 -- mentioned in multiple constructors, the SrcLoc will be from the first
606 -- occurence. We use the equality to filter out duplicate field names
608 hsTyClDeclBinders (L _ (TyFamily {tcdLName = name})) = [name]
609 hsTyClDeclBinders (L _ (TySynonym {tcdLName = name})) = [name]
610 hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
612 hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
614 concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs]
616 hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons}))
617 = tc_name : hsConDeclsBinders cons
619 hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
620 -- See hsTyClDeclBinders for what this does
621 -- The function is boringly complicated because of the records
622 -- And since we only have equality, we have to be a little careful
623 hsConDeclsBinders cons
624 = snd (foldl do_one ([], []) cons)
626 do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
627 = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
629 new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
630 (map cd_fld_name flds)
632 do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
633 = (flds_seen, lname:acc)
637 %************************************************************************
639 Collecting binders the user did not write
641 %************************************************************************
643 The job of this family of functions is to run through binding sites and find the set of all Names
644 that were defined "implicitly", without being explicitly written by the user.
646 The main purpose is to find names introduced by record wildcards so that we can avoid
647 warning the user when they don't use those names (#4404)
650 lStmtsImplicits :: [LStmtLR Name idR] -> NameSet
651 lStmtsImplicits = hs_lstmts
653 hs_lstmts :: [LStmtLR Name idR] -> NameSet
654 hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet
656 hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
657 hs_stmt (LetStmt binds) = hs_local_binds binds
658 hs_stmt (ExprStmt {}) = emptyNameSet
659 hs_stmt (LastStmt {}) = emptyNameSet
660 hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs
662 hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts
663 hs_stmt (GroupStmt { grpS_stmts = stmts }) = hs_lstmts stmts
664 hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
666 hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
667 hs_local_binds (HsIPBinds _) = emptyNameSet
668 hs_local_binds EmptyLocalBinds = emptyNameSet
670 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
671 hsValBindsImplicits (ValBindsOut binds _)
672 = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds]
674 hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
675 hs_bind _ = emptyNameSet
676 hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty
678 lPatImplicits :: LPat Name -> NameSet
679 lPatImplicits = hs_lpat
681 hs_lpat (L _ pat) = hs_pat pat
683 hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet
685 hs_pat (LazyPat pat) = hs_lpat pat
686 hs_pat (BangPat pat) = hs_lpat pat
687 hs_pat (AsPat _ pat) = hs_lpat pat
688 hs_pat (ViewPat _ pat _) = hs_lpat pat
689 hs_pat (ParPat pat) = hs_lpat pat
690 hs_pat (ListPat pats _) = hs_lpats pats
691 hs_pat (PArrPat pats _) = hs_lpats pats
692 hs_pat (TuplePat pats _ _) = hs_lpats pats
694 hs_pat (SigPatIn pat _) = hs_lpat pat
695 hs_pat (SigPatOut pat _) = hs_lpat pat
696 hs_pat (CoPat _ pat _) = hs_pat pat
698 hs_pat (ConPatIn _ ps) = details ps
699 hs_pat (ConPatOut {pat_args=ps}) = details ps
701 hs_pat _ = emptyNameSet
703 details (PrefixCon ps) = hs_lpats ps
704 details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit)
705 where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat
706 | (i, fld) <- [0..] `zip` rec_flds fs
707 , let pat = hsRecFieldArg fld
708 pat_explicit = maybe True (i<) (rec_dotdot fs)]
709 details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2
713 %************************************************************************
715 Collecting type signatures from patterns
717 %************************************************************************
720 collectSigTysFromPats :: [InPat name] -> [LHsType name]
721 collectSigTysFromPats pats = foldr collect_sig_lpat [] pats
723 collectSigTysFromPat :: InPat name -> [LHsType name]
724 collectSigTysFromPat pat = collect_sig_lpat pat []
726 collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
727 collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
729 collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
730 collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
731 collect_sig_pat (TypePat ty) acc = ty:acc
733 collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc
734 collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc
735 collect_sig_pat (AsPat _ pat) acc = collect_sig_lpat pat acc
736 collect_sig_pat (ParPat pat) acc = collect_sig_lpat pat acc
737 collect_sig_pat (ListPat pats _) acc = foldr collect_sig_lpat acc pats
738 collect_sig_pat (PArrPat pats _) acc = foldr collect_sig_lpat acc pats
739 collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
740 collect_sig_pat (ConPatIn _ ps) acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
741 collect_sig_pat _ acc = acc -- Literals, vars, wildcard