get names of data constructors

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

diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs
index 2b713fe..88c2dcb 100644 (file)
--- a/utils/ghctags/GhcTags.hs
+++ b/utils/ghctags/GhcTags.hs
@@ -51,11 +51,21 @@ main = do
           session <- newSession JustTypecheck
           print "created a session"
           flags <- getSessionDynFlags session
-          (flags, _) <- parseDynamicFlags flags ghcArgs
+          (pflags, _) <- parseDynamicFlags flags ghcArgs
+          let flags = pflags { hscTarget = HscNothing }
           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
@@ -182,29 +192,19 @@ modsummary graph n =
 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 []
+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
+              in  do mod <- checkModule session (moduleName $ ms_mod ms)
+                     return $ maybe (FileData filename []) id $ do
+                       m <- mod
+                       s <- renamedSource m
+                       return $ fileData filename s
 
 fileData :: FileName -> RenamedSource -> FileData
 fileData filename (group, imports, lie) =
@@ -220,7 +220,8 @@ boundValues group =
       tys = concat $ map tyBound (hs_tyclds group)
             where tyBound ltcd = case unLoc ltcd of
                                    ForeignType { tcdLName = n } -> [foundOfLName n]
-                                   TyData { tcdLName = n } -> [foundOfLName n]
+                                   TyData { tcdLName = tycon, tcdCons = cons } ->
+                                       dataNames tycon cons
                                    TySynonym { tcdLName = n } -> [foundOfLName n]
                                    ClassDecl { tcdLName = n } -> [foundOfLName n]
       fors = concat $ map forBound (hs_fords group)
@@ -228,6 +229,8 @@ boundValues group =
                                       ForeignImport n _ _ -> [foundOfLName n]
                                       ForeignExport { } -> []
   in vals ++ tys ++ fors
+  where dataNames tycon cons = foundOfLName tycon : map conName cons
+        conName td = foundOfLName $ con_name $ unLoc td
 
 posOfLocated :: Located a -> Pos
 posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
@@ -243,3 +246,4 @@ boundThings lbinding =
         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
+