X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FhsSyn%2FHsSyn.lhs;h=2fc0323a2dc974d50e893314f4e3e7a87abd20a4;hb=c7b389309e5cdc86db9845573900b560c7a2fa05;hp=7255d1b7f681a08d2ec596d57b9293eee9bb0e6f;hpb=49fabae45e348e93d25064e469dc777eb3bfc56d;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 7255d1b..2fc0323 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -101,94 +101,3 @@ instance (OutputableBndr name) pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs) \end{code} - - -%************************************************************************ -%* * -\subsection{Collecting binders from @HsBinds@} -%* * -%************************************************************************ - -Get all the binders in some @MonoBinds@, IN THE ORDER OF APPEARANCE. - -These functions are here, rather than in HsBinds, to avoid a loop between HsPat and HsBinds. - -\begin{verbatim} -... -where - (x, y) = ... - f i j = ... - [a, b] = ... -\end{verbatim} -it should return @[x, y, f, a, b]@ (remember, order important). - -\begin{code} -collectGroupBinders :: [HsBindGroup name] -> [Located name] -collectGroupBinders groups = foldr collect_group [] groups - where - collect_group (HsBindGroup bag sigs is_rec) acc - = foldrBag (collectAcc . unLoc) acc bag - collect_group (HsIPBinds _) acc = acc - - -collectAcc :: HsBind name -> [Located name] -> [Located name] -collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc -collectAcc (FunBind f _ _) acc = f : acc -collectAcc (VarBind f _) acc = noLoc f : acc -collectAcc (AbsBinds _ _ dbinds _ binds) acc - = [noLoc dp | (_,dp,_) <- dbinds] ++ acc - -- ++ foldr collectAcc acc binds - -- I don't think we want the binders from the nested binds - -- The only time we collect binders from a typechecked - -- binding (hence see AbsBinds) is in zonking in TcHsSyn - -collectHsBindBinders :: Bag (LHsBind name) -> [name] -collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) - -collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name] -collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds -\end{code} - - -%************************************************************************ -%* * -\subsection{Getting patterns out of bindings} -%* * -%************************************************************************ - -Get all the pattern type signatures out of a bunch of bindings - -\begin{code} -collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name] -collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds) - -collectSigTysFromHsBind :: LHsBind name -> [LHsType name] -collectSigTysFromHsBind bind - = go (unLoc bind) - where - go (PatBind pat _) = collectSigTysFromPat pat - go (FunBind f _ ms) = go_matches (map unLoc ms) - - -- A binding like x :: a = f y - -- is parsed as FunMonoBind, but for this purpose we - -- want to treat it as a pattern binding - go_matches [] = [] - go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches - go_matches (match : matches) = go_matches matches -\end{code} - -\begin{code} -collectStmtsBinders :: [LStmt id] -> [Located id] -collectStmtsBinders = concatMap collectLStmtBinders - -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: Stmt id -> [Located id] - -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat -collectStmtBinders (LetStmt binds) = collectGroupBinders binds -collectStmtBinders (ExprStmt _ _) = [] -collectStmtBinders (ResultStmt _) = [] -collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss -collectStmtBinders other = panic "collectStmtBinders" -\end{code}