From 63d684b1e1d08ea60c3441f287d7a680ce81c153 Mon Sep 17 00:00:00 2001 From: Norman Ramsey Date: Wed, 20 Sep 2006 04:27:57 +0000 Subject: [PATCH] first cut at missing case for ids defined in pattern --- utils/ghctags/GhcTags.hs | 39 ++++++++++++++++++++++++++++++++------- 1 file changed, 32 insertions(+), 7 deletions(-) diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs index 5fcdc82..fb79a6a 100644 --- a/utils/ghctags/GhcTags.hs +++ b/utils/ghctags/GhcTags.hs @@ -229,10 +229,35 @@ foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated i boundThings :: ModuleName -> LHsBind Name -> [FoundThing] boundThings modname lbinding = - let thing = foundOfLName modname - in case unLoc lbinding of - FunBind { fun_id = id } -> [thing id] - PatBind { pat_lhs = lhs } -> panic "Pattern at top level" - VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)] - AbsBinds { } -> [] -- nothing interesting in a type abstraction - + case unLoc lbinding of + FunBind { fun_id = id } -> [thing id] + PatBind { pat_lhs = lhs } -> patThings lhs [] + VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)] + AbsBinds { } -> [] -- nothing interesting in a type abstraction + where thing = foundOfLName modname + patThings lpat tl = + let loc = startOfLocated lpat + lid id = FoundThing modname (getOccString id) loc + in case unLoc lpat of + WildPat _ -> tl + VarPat name -> lid name : tl + VarPatOut name _ -> lid name : tl -- XXX need help here + LazyPat p -> patThings p tl + AsPat id p -> patThings p (thing id : tl) + ParPat p -> patThings p tl + BangPat p -> patThings p tl + ListPat ps _ -> foldr patThings tl ps + TuplePat ps _ _ -> foldr patThings tl ps + PArrPat ps _ -> foldr patThings tl ps + ConPatIn _ conargs -> conArgs conargs tl + ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl + LitPat _ -> tl + NPat _ _ _ _ -> tl -- form of literal pattern? + NPlusKPat id _ _ _ -> thing id : tl + TypePat _ -> tl -- XXX need help here + SigPatIn p _ -> patThings p tl + SigPatOut p _ -> patThings p tl + DictPat _ _ -> tl + conArgs (PrefixCon ps) tl = foldr patThings tl ps + conArgs (RecCon pairs) tl = foldr (\(_id, p) tl -> patThings p tl) tl pairs + conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl -- 1.7.10.4