From 58e8b8c65d1520c79881945ed423cc436ae06f32 Mon Sep 17 00:00:00 2001
From: Norman Ramsey <nr@eecs.harvard.edu>
Date: Sat, 16 Sep 2006 23:27:55 +0000
Subject: [PATCH] cover more cases; take GHC options on command line Bit of a
 dog's breakfast here:   * generate tags for more cases in
 the syntax   * accept -package ghc and other args on
 command line   * scrub away old code for snaffling thru
 text

---
 utils/ghctags/GhcTags.hs |   80 ++++++++++++++++++++--------------------------
 1 file changed, 34 insertions(+), 46 deletions(-)

diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs
index fe5cd64..2b713fe 100644
--- a/utils/ghctags/GhcTags.hs
+++ b/utils/ghctags/GhcTags.hs
@@ -31,10 +31,12 @@ placateGhc = defaultErrorHandler defaultDynFlags $ do
 main :: IO ()
 main = do
         progName <- getProgName
+        let usageString =
+              "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
 	args <- getArgs
-        let usageString = "Usage: " ++ progName ++ " [OPTION...] [files...]"
-	let (modes, filenames, errs) = getOpt Permute options args
-	if errs /= [] || elem Help modes || filenames == []
+        let (ghcArgs, ourArgs, unbalanced) = splitArgs args
+	let (modes, filenames, errs) = getOpt Permute options ourArgs
+	if unbalanced || errs /= [] || elem Help modes || filenames == []
          then do
            putStr $ unlines errs 
 	   putStr $ usageInfo usageString options
@@ -49,7 +51,7 @@ main = do
           session <- newSession JustTypecheck
           print "created a session"
           flags <- getSessionDynFlags session
-          (flags, _) <- parseDynamicFlags flags ["-package", "ghc"]
+          (flags, _) <- parseDynamicFlags flags ghcArgs
           GHC.defaultCleanupHandler flags $ do
             flags <- initPackages flags
             setSessionDynFlags session flags
@@ -76,6 +78,13 @@ getMode [x] = x
 getMode (x:xs) = max x (getMode xs)
 
 
+splitArgs :: [String] -> ([String], [String], Bool)
+-- pull out arguments between -- for GHC
+splitArgs args = split [] [] False args
+    where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
+          split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
+          split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
+
 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
 
 options :: [OptDescr Mode]
@@ -205,53 +214,32 @@ fileData filename (group, imports, lie) =
 
 boundValues :: HsGroup Name -> [FoundThing]    
 boundValues group =
-  case hs_valds group of
-    ValBindsOut nest sigs ->
-        [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
+  let vals = case hs_valds group of
+               ValBindsOut nest sigs ->
+                   [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
+      tys = concat $ map tyBound (hs_tyclds group)
+            where tyBound ltcd = case unLoc ltcd of
+                                   ForeignType { tcdLName = n } -> [foundOfLName n]
+                                   TyData { tcdLName = n } -> [foundOfLName n]
+                                   TySynonym { tcdLName = n } -> [foundOfLName n]
+                                   ClassDecl {	tcdLName = n } -> [foundOfLName n]
+      fors = concat $ map forBound (hs_fords group)
+             where forBound lford = case unLoc lford of
+                                      ForeignImport n _ _ -> [foundOfLName n]
+                                      ForeignExport { } -> []
+  in vals ++ tys ++ fors
 
 posOfLocated :: Located a -> Pos
 posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
 
+foundOfLName :: Located Name -> FoundThing
+foundOfLName id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
+
 boundThings :: LHsBind Name -> [FoundThing]
 boundThings lbinding = 
-  let thing id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
+  let thing = foundOfLName
   in  case unLoc lbinding of
         FunBind { fun_id = id } -> [thing id]
-        PatBind { pat_lhs = lhs } -> patBoundIds lhs
---        VarBind { var_id = id } -> [thing id]
-        _ -> []
-                                     
-
-patBoundIds :: a -> b
-patBoundIds _ = panic "not on your life"
-	
--- actually pick up definitions
-
-findstuff :: [Token] -> [FoundThing]
-findstuff ((Token "data" _):(Token name pos):xs) = 
-	FoundThing name pos : (getcons xs) ++ (findstuff xs)
-findstuff ((Token "newtype" _):(Token name pos):xs) = 
-	FoundThing name pos : findstuff xs
-findstuff ((Token "type" _):(Token name pos):xs) = 
-	FoundThing name pos : findstuff xs
-findstuff ((Token name pos):(Token "::" _):xs) = 
-	FoundThing name pos : findstuff xs
-findstuff (x:xs) = findstuff xs
-findstuff [] = []
-
-
--- get the constructor definitions, knowing that a datatype has just started
-
-getcons :: [Token] -> [FoundThing]
-getcons ((Token "=" _):(Token name pos):xs) = 
-	FoundThing name pos : getcons2 xs
-getcons (x:xs) = getcons xs
-getcons [] = []
-
-
-getcons2 ((Token "=" _):xs) = []
-getcons2 ((Token "|" _):(Token name pos):xs) = 
-	FoundThing name pos : getcons2 xs
-getcons2 (x:xs) = getcons2 xs
-getcons2 [] = []
-
+        PatBind { pat_lhs = lhs } -> panic "Pattern at top level"
+        VarBind { var_id = id } -> [FoundThing (getOccString id) (posOfLocated lbinding)]
+        AbsBinds { } -> [] -- nothing interesting in a type abstraction
-- 
1.7.10.4