[project @ 2005-06-13 14:12:59 by simonmar]

Implement :tags command

Patch supplied by Claus Reinke, with some modifications by me.
Ideally we'd like this to be a command line option too, and we'd like
to drop the restriction that all the source files must be interpreted,
but that needs some work elsewhere (interface files have to store
definition source locations).

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index b33bd95..5f74551 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -22,6 +22,12 @@ import GHC           ( Session, verbosity, dopt, DynFlag(..),
                          CheckedModule(..) )
 import Outputable
 
+-- for createtags (should these come via GHC?)
+import Module( moduleUserString )
+import Name( nameSrcLoc, nameModule, nameOccName )
+import OccName( pprOccName )
+import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
+
 -- following all needed for :info... ToDo: remove
 import IfaceSyn                ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
                          IfaceConDecl(..), IfaceType,
@@ -38,11 +44,10 @@ import Config
 import StaticFlags     ( opt_IgnoreDotGhci )
 import Linker          ( showLinkerState )
 import Util            ( removeSpaces, handle, global, toArgs,
-                         looksLikeModuleName, prefixMatch )
+                         looksLikeModuleName, prefixMatch, sortLe )
 import ErrUtils                ( printErrorsAndWarnings )
 
 #ifndef mingw32_HOST_OS
-import Util            ( handle )
 import System.Posix
 #if __GLASGOW_HASKELL__ > 504
        hiding (getEnv)
@@ -110,6 +115,7 @@ builtin_commands = [
   ("check",    keepGoing checkModule),
   ("set",      keepGoing setCmd),
   ("show",     keepGoing showCmd),
+  ("tags",     keepGoing createTagsFileCmd),
   ("type",     keepGoing typeOfExpr),
   ("kind",     keepGoing kindOfType),
   ("unset",    keepGoing unsetOptions),
@@ -147,6 +153,7 @@ helpText =
  "   :show modules               show the currently loaded modules\n" ++
  "   :show bindings              show the current bindings made at the prompt\n" ++
  "\n" ++
+ "   :tags -e|-c                create tags file for Vi (-c) or Emacs (-e)\n" ++
  "   :type <expr>                show the type of <expr>\n" ++
  "   :kind <type>                show the kind of <type>\n" ++
  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
@@ -476,9 +483,6 @@ specialCommand str = do
                                       foldr1 (\a b -> a ++ ',':b) (map fst cs)
                                         ++ ")") >> return False)
 
-noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
-
-
 -----------------------------------------------------------------------------
 -- To flush buffers for the *interpreted* computation we need
 -- to refer to *its* stdout/stderr handles
@@ -840,6 +844,114 @@ shellEscape :: String -> GHCi Bool
 shellEscape str = io (system str >> return False)
 
 -----------------------------------------------------------------------------
+-- create tags file for currently loaded modules.
+
+createTagsFileCmd :: String -> GHCi ()
+createTagsFileCmd "-c" = ghciCreateTagsFile CTags "tags"
+createTagsFileCmd "-e" = ghciCreateTagsFile ETags "TAGS"
+createTagsFileCmd _  = throwDyn (CmdLineError "syntax:  :tags -c|-e")
+
+data TagsKind = ETags | CTags
+
+ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
+ghciCreateTagsFile kind file = do
+  session <- getSession
+  io $ createTagsFile session kind file
+
+-- ToDo: 
+--     - remove restriction that all modules must be interpreted
+--       (problem: we don't know source locations for entities unless
+--       we compiled the module.
+--
+--     - extract createTagsFile so it can be used from the command-line
+--       (probably need to fix first problem before this is useful).
+--
+createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
+createTagsFile session tagskind tagFile = do
+  graph <- GHC.getModuleGraph session
+  let ms = map GHC.ms_mod graph
+      tagModule m = do 
+        is_interpreted <- GHC.moduleIsInterpreted session m
+        -- should we just skip these?
+        when (not is_interpreted) $
+          throwDyn (CmdLineError ("module '" ++ moduleUserString m ++ "' is not interpreted"))
+
+        mbModInfo <- GHC.getModuleInfo session m
+        let unqual 
+             | Just modinfo <- mbModInfo,
+               Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
+             | otherwise = GHC.alwaysQualify
+
+        case mbModInfo of 
+          Just modInfo -> return $! listTags unqual modInfo 
+          _            -> return []
+
+  mtags <- mapM tagModule ms
+  either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
+  case either_res of
+    Left e  -> hPutStrLn stderr $ ioeGetErrorString e
+    Right _ -> return ()
+
+listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
+listTags unqual modInfo =
+          [ tagInfo unqual name loc 
+           | name <- GHC.modInfoExports modInfo
+           , let loc = nameSrcLoc name
+           , isGoodSrcLoc loc
+           ]
+
+type TagInfo = (String -- tag name
+               ,String -- file name
+               ,Int    -- line number
+               ,Int    -- column number
+               )
+
+-- get tag info, for later translation into Vim or Emacs style
+tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
+tagInfo unqual name loc
+    = ( showSDocForUser unqual $ pprOccName (nameOccName name)
+      , showSDocForUser unqual $ ftext (srcLocFile loc)
+      , srcLocLine loc
+      , srcLocCol loc
+      )
+
+collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
+collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
+  let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
+  IO.try (writeFile file tags)
+collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
+  let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
+      groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
+  tagGroups <- mapM tagFileGroup groups 
+  IO.try (writeFile file $ concat tagGroups)
+  where
+    tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
+    tagFileGroup group@((_,fileName,_,_):_) = do
+      file <- readFile fileName -- need to get additional info from sources..
+      let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
+          sortedGroup = sortLe byLine group
+          tags = unlines $ perFile sortedGroup 1 0 $ lines file
+      return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
+    perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
+      perFile (tagInfo:tags) (count+1) (pos+length line) lines
+    perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
+      showETag tagInfo line pos : perFile tags count pos lines
+    perFile tags count pos lines = []
+
+-- simple ctags format, for Vim et al
+showTag :: TagInfo -> String
+showTag (tag,file,lineNo,colNo)
+    =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
+
+-- etags format, for Emacs/XEmacs
+showETag :: TagInfo -> String -> Int -> String
+showETag (tag,file,lineNo,colNo) line charPos
+    =  take colNo line ++ tag
+    ++ "\x7f" ++ tag
+    ++ "\x01" ++ show lineNo
+    ++ "," ++ show charPos
+
+-----------------------------------------------------------------------------
 -- Browsing a module's contents
 
 browseCmd :: String -> GHCi ()