change representation of FoundThing

[ghc-hetmet.git] / utils / ghctags / GhcTags.hs

diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs
index fe5cd64..5fcdc82 100644 (file)
--- a/utils/ghctags/GhcTags.hs
+++ b/utils/ghctags/GhcTags.hs
@@ -31,10 +31,12 @@ placateGhc = defaultErrorHandler defaultDynFlags $ do
 main :: IO ()
 main = do
         progName <- getProgName
 main :: IO ()
 main = do
         progName <- getProgName

+        let usageString =
+              "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"

        args <- getArgs
        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
          then do
            putStr $ unlines errs 
           putStr $ usageInfo usageString options

@@ -49,11 +51,21 @@ main = do
           session <- newSession JustTypecheck
           print "created a session"
           flags <- getSessionDynFlags session
           session <- newSession JustTypecheck
           print "created a session"
           flags <- getSessionDynFlags session

-          (flags, _) <- parseDynamicFlags flags ["-package", "ghc"]
+          (pflags, _) <- parseDynamicFlags flags ghcArgs
+          let flags = pflags { hscTarget = HscNothing }

           GHC.defaultCleanupHandler flags $ do
             flags <- initPackages flags
             setSessionDynFlags session flags
           GHC.defaultCleanupHandler flags $ do
             flags <- initPackages flags
             setSessionDynFlags session flags

-          filedata <- mapM (findthings session) filenames
+          setTargets session (map fileTarget filenames)
+          print "set targets"
+          success <- load session LoadAllTargets  --- bring module graph up to date
+          filedata <- case success of
+                        Failed -> do { putStr "Load failed"; exitWith (ExitFailure 2) }
+                        Succeeded -> do
+                                     print "loaded all targets"
+                                     graph <- getModuleGraph session
+                                     print "got modules graph"
+                                     graphData session graph

           if mode == BothTags || mode == CTags
            then do 
              ctagsfile <- openFile "tags" openFileMode
           if mode == BothTags || mode == CTags
            then do 
              ctagsfile <- openFile "tags" openFileMode

@@ -76,6 +88,13 @@ getMode [x] = x
 getMode (x:xs) = max x (getMode xs)
 
 
 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]
 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
 
 options :: [OptDescr Mode]

@@ -94,29 +113,12 @@ type FileName = String
 
 type ThingName = String
 
 
 type ThingName = String
 

--- The position of a token or definition
-data Pos = Pos 
-               FileName        -- file name
-               Int                     -- line number 
-               Int             -- token number
-               String          -- string that makes up that line
-       deriving Show
-
-srcLocToPos :: SrcLoc -> Pos
-srcLocToPos loc =
-    Pos (unpackFS $ srcLocFile loc) (srcLocLine loc) (srcLocCol loc) "bogus"
-

 -- A definition we have found
 -- A definition we have found

-data FoundThing = FoundThing ThingName Pos
-       deriving Show
+data FoundThing = FoundThing ModuleName ThingName SrcLoc

 
 -- Data we have obtained from a file
 data FileData = FileData FileName [FoundThing]
 
 
 -- Data we have obtained from a file
 data FileData = FileData FileName [FoundThing]
 

-data Token = Token String Pos
-       deriving Show
-
-

 -- stuff for dealing with ctags output format
 
 writectagsfile :: Handle -> [FileData] -> IO ()
 -- stuff for dealing with ctags output format
 
 writectagsfile :: Handle -> [FileData] -> IO ()

@@ -128,8 +130,10 @@ getfoundthings :: FileData -> [FoundThing]
 getfoundthings (FileData filename things) = things
 
 dumpthing :: FoundThing -> String
 getfoundthings (FileData filename things) = things
 
 dumpthing :: FoundThing -> String

-dumpthing (FoundThing name (Pos filename line _ _)) = 
+dumpthing (FoundThing modname name loc) =

        name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
        name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)

+    where line = srcLocLine loc
+          filename = unpackFS $ srcLocFile loc

 
 
 -- stuff for dealing with etags output format
 
 
 -- stuff for dealing with etags output format

@@ -146,10 +150,11 @@ e_dumpfiledata (FileData filename things) =
                thingslength = length thingsdump
 
 e_dumpthing :: FoundThing -> String
                thingslength = length thingsdump
 
 e_dumpthing :: FoundThing -> String

-e_dumpthing (FoundThing name (Pos filename line token fullline)) =
-       ---- (concat $ take (token + 1) $ spacedwords fullline) 
-        name
-       ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
+e_dumpthing (FoundThing modname name loc) =
+    tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
+    where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
+          line = srcLocLine loc
+       

        
        
 -- like "words", but keeping the whitespace, and so letting us build
        
        
 -- like "words", but keeping the whitespace, and so letting us build

@@ -173,85 +178,61 @@ modsummary graph n =
 modname :: ModSummary -> ModuleName
 modname summary = moduleName $ ms_mod $ summary
 
 modname :: ModSummary -> ModuleName
 modname summary = moduleName $ ms_mod $ summary
 

-findthings :: Session -> FileName -> IO FileData
-findthings session filename = do
-  setTargets session [Target (TargetFile filename Nothing) Nothing]
-  print "set targets"
-  success <- load session LoadAllTargets  --- bring module graph up to date
-  case success of
-    Failed -> do { print "load failed"; return emptyFileData }
-    Succeeded ->
-      do print "loaded all targets"
-         graph <- getModuleGraph session
-         print "got modules graph"
-         case  modsummary graph filename of
-           Nothing -> panic "loaded a module from a file but then could not find its summary"
-           Just ms -> do
-             mod <- checkModule session (modname ms)
-             print "got the module"
-             case mod of
-               Nothing -> return emptyFileData
-               Just m -> case renamedSource m of
-                           Nothing -> return emptyFileData
-                           Just s -> return $ fileData filename s
-  where emptyFileData = FileData filename []
-
-
-fileData :: FileName -> RenamedSource -> FileData
-fileData filename (group, imports, lie) =
+fileTarget :: FileName -> Target
+fileTarget filename = Target (TargetFile filename Nothing) Nothing
+
+graphData :: Session -> ModuleGraph -> IO [FileData]
+graphData session graph =
+    mapM foundthings graph
+    where foundthings ms =
+              let filename = msHsFilePath ms
+                  modname = moduleName $ ms_mod ms
+              in  do mod <- checkModule session modname
+                     return $ maybe (FileData filename []) id $ do
+                       m <- mod
+                       s <- renamedSource m
+                       return $ fileData filename modname s
+
+fileData :: FileName -> ModuleName -> RenamedSource -> FileData
+fileData filename modname (group, imports, lie) =

     -- lie is related to type checking and so is irrelevant
     -- imports contains import declarations and no definitions
     -- lie is related to type checking and so is irrelevant
     -- imports contains import declarations and no definitions

-    FileData filename (boundValues group)
-
-boundValues :: HsGroup Name -> [FoundThing]    
-boundValues group =
-  case hs_valds group of
-    ValBindsOut nest sigs ->
-        [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
-
-posOfLocated :: Located a -> Pos
-posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
-
-boundThings :: LHsBind Name -> [FoundThing]
-boundThings lbinding = 
-  let thing id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
+    FileData filename (boundValues modname group)
+
+boundValues :: ModuleName -> HsGroup Name -> [FoundThing]    
+boundValues mod group =
+  let vals = case hs_valds group of
+               ValBindsOut nest sigs ->
+                   [ x | (_rec, binds) <- nest, bind <- bagToList binds,
+                              x <- boundThings mod bind ]
+      tys = concat $ map tyBound (hs_tyclds group)
+            where tyBound ltcd = case unLoc ltcd of
+                                   ForeignType { tcdLName = n } -> [found n]
+                                   TyData { tcdLName = tycon, tcdCons = cons } ->
+                                       dataNames tycon cons
+                                   TySynonym { tcdLName = n } -> [found n]
+                                   ClassDecl { tcdLName = n } -> [found n]
+      fors = concat $ map forBound (hs_fords group)
+             where forBound lford = case unLoc lford of
+                                      ForeignImport n _ _ -> [found n]
+                                      ForeignExport { } -> []
+  in vals ++ tys ++ fors
+  where dataNames tycon cons = found tycon : map conName cons
+        conName td = found $ con_name $ unLoc td
+        found = foundOfLName mod
+
+startOfLocated :: Located a -> SrcLoc
+startOfLocated lHs = srcSpanStart $ getLoc lHs
+
+foundOfLName :: ModuleName -> Located Name -> FoundThing
+foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
+
+boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
+boundThings modname lbinding = 
+  let thing = foundOfLName modname

   in  case unLoc lbinding of
         FunBind { fun_id = id } -> [thing id]
   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 modname (getOccString id) (startOfLocated lbinding)]
+        AbsBinds { } -> [] -- nothing interesting in a type abstraction