utils/ghctags/GhcTags.hs

   1 module Main where
   2 import Bag
   3 import Char
   4 import DynFlags(GhcMode, defaultDynFlags)
   5 import FastString
   6 import GHC
   7 import HscTypes (msHsFilePath)
   8 import List
   9 import IO
  10 import Name
  11 import Outputable
  12 import SrcLoc
  13 import System.Environment
  14 import System.Console.GetOpt
  15 import System.Exit
  16
  17
  18 -- search for definitions of things
  19 -- we do this by parsing the source and grabbing top-level definitions
  20
  21 -- We generate both CTAGS and ETAGS format tags files
  22 -- The former is for use in most sensible editors, while EMACS uses ETAGS
  23
  24 {-
  25 placateGhc :: IO ()
  26 placateGhc = defaultErrorHandler defaultDynFlags $ do
  27   GHC.init (Just "/usr/local/lib/ghc-6.5")  -- or your build tree!
  28   s <- newSession mode
  29 -}
  30
  31 main :: IO ()
  32 main = do
  33         progName <- getProgName
  34         let usageString =
  35               "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
  36         args <- getArgs
  37         let (ghcArgs, ourArgs, unbalanced) = splitArgs args
  38         let (modes, filenames, errs) = getOpt Permute options ourArgs
  39         if unbalanced || errs /= [] || elem Help modes || filenames == []
  40          then do
  41            putStr $ unlines errs
  42            putStr $ usageInfo usageString options
  43            exitWith (ExitFailure 1)
  44          else return ()
  45         let mode = getMode (Append `delete` modes)
  46         let openFileMode = if elem Append modes
  47                            then AppendMode
  48                            else WriteMode
  49         GHC.init (Just "/usr/local/lib/ghc-6.5")
  50         GHC.defaultErrorHandler defaultDynFlags $ do
  51           session <- newSession JustTypecheck
  52           print "created a session"
  53           flags <- getSessionDynFlags session
  54           (pflags, _) <- parseDynamicFlags flags ghcArgs
  55           let flags = pflags { hscTarget = HscNothing }
  56           GHC.defaultCleanupHandler flags $ do
  57             flags <- initPackages flags
  58             setSessionDynFlags session flags
  59           setTargets session (map fileTarget filenames)
  60           print "set targets"
  61           success <- load session LoadAllTargets  --- bring module graph up to date
  62           filedata <- case success of
  63                         Failed -> do { putStr "Load failed"; exitWith (ExitFailure 2) }
  64                         Succeeded -> do
  65                                      print "loaded all targets"
  66                                      graph <- getModuleGraph session
  67                                      print "got modules graph"
  68                                      graphData session graph
  69           if mode == BothTags || mode == CTags
  70            then do
  71              ctagsfile <- openFile "tags" openFileMode
  72              writectagsfile ctagsfile filedata
  73              hClose ctagsfile
  74            else return ()
  75           if mode == BothTags || mode == ETags
  76            then do
  77              etagsfile <- openFile "TAGS" openFileMode
  78              writeetagsfile etagsfile filedata
  79              hClose etagsfile
  80            else return ()
  81
  82 -- | getMode takes a list of modes and extract the mode with the
  83 --   highest precedence.  These are as follows: Both, CTags, ETags
  84 --   The default case is Both.
  85 getMode :: [Mode] -> Mode
  86 getMode [] = BothTags
  87 getMode [x] = x
  88 getMode (x:xs) = max x (getMode xs)
  89
  90
  91 splitArgs :: [String] -> ([String], [String], Bool)
  92 -- pull out arguments between -- for GHC
  93 splitArgs args = split [] [] False args
  94     where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
  95           split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
  96           split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
  97
  98 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
  99
 100 options :: [OptDescr Mode]
 101 options = [ Option "c" ["ctags"]
 102             (NoArg CTags) "generate CTAGS file (ctags)"
 103           , Option "e" ["etags"]
 104             (NoArg ETags) "generate ETAGS file (etags)"
 105           , Option "b" ["both"]
 106             (NoArg BothTags) ("generate both CTAGS and ETAGS")
 107           , Option "a" ["append"]
 108             (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)")
 109           , Option "h" ["help"] (NoArg Help) "This help"
 110           ]
 111
 112 type FileName = String
 113
 114 type ThingName = String
 115
 116 -- A definition we have found
 117 data FoundThing = FoundThing ModuleName ThingName SrcLoc
 118
 119 -- Data we have obtained from a file
 120 data FileData = FileData FileName [FoundThing]
 121
 122 -- stuff for dealing with ctags output format
 123
 124 writectagsfile :: Handle -> [FileData] -> IO ()
 125 writectagsfile ctagsfile filedata = do
 126         let things = concat $ map getfoundthings filedata
 127         mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
 128
 129 getfoundthings :: FileData -> [FoundThing]
 130 getfoundthings (FileData filename things) = things
 131
 132 dumpthing :: FoundThing -> String
 133 dumpthing (FoundThing modname name loc) =
 134         name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
 135     where line = srcLocLine loc
 136           filename = unpackFS $ srcLocFile loc
 137
 138
 139 -- stuff for dealing with etags output format
 140
 141 writeetagsfile :: Handle -> [FileData] -> IO ()
 142 writeetagsfile etagsfile filedata = do
 143         mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
 144
 145 e_dumpfiledata :: FileData -> String
 146 e_dumpfiledata (FileData filename things) =
 147         "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
 148         where
 149                 thingsdump = concat $ map e_dumpthing things
 150                 thingslength = length thingsdump
 151
 152 e_dumpthing :: FoundThing -> String
 153 e_dumpthing (FoundThing modname name loc) =
 154     tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
 155     where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
 156           line = srcLocLine loc
 157
 158
 159
 160 -- like "words", but keeping the whitespace, and so letting us build
 161 -- accurate prefixes
 162
 163 spacedwords :: String -> [String]
 164 spacedwords [] = []
 165 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
 166         where
 167                 (blanks,rest) = span Char.isSpace xs
 168                 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
 169
 170
 171 -- Find the definitions in a file
 172
 173 modsummary :: ModuleGraph -> FileName -> Maybe ModSummary
 174 modsummary graph n =
 175   List.find matches graph
 176   where matches ms = n == msHsFilePath ms
 177
 178 modname :: ModSummary -> ModuleName
 179 modname summary = moduleName $ ms_mod $ summary
 180
 181 fileTarget :: FileName -> Target
 182 fileTarget filename = Target (TargetFile filename Nothing) Nothing
 183
 184 graphData :: Session -> ModuleGraph -> IO [FileData]
 185 graphData session graph =
 186     mapM foundthings graph
 187     where foundthings ms =
 188               let filename = msHsFilePath ms
 189                   modname = moduleName $ ms_mod ms
 190               in  do mod <- checkModule session modname
 191                      return $ maybe (FileData filename []) id $ do
 192                        m <- mod
 193                        s <- renamedSource m
 194                        return $ fileData filename modname s
 195
 196 fileData :: FileName -> ModuleName -> RenamedSource -> FileData
 197 fileData filename modname (group, imports, lie) =
 198     -- lie is related to type checking and so is irrelevant
 199     -- imports contains import declarations and no definitions
 200     FileData filename (boundValues modname group)
 201
 202 boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
 203 boundValues mod group =
 204   let vals = case hs_valds group of
 205                ValBindsOut nest sigs ->
 206                    [ x | (_rec, binds) <- nest, bind <- bagToList binds,
 207                               x <- boundThings mod bind ]
 208       tys = concat $ map tyBound (hs_tyclds group)
 209             where tyBound ltcd = case unLoc ltcd of
 210                                    ForeignType { tcdLName = n } -> [found n]
 211                                    TyData { tcdLName = tycon, tcdCons = cons } ->
 212                                        dataNames tycon cons
 213                                    TySynonym { tcdLName = n } -> [found n]
 214                                    ClassDecl {  tcdLName = n } -> [found n]
 215       fors = concat $ map forBound (hs_fords group)
 216              where forBound lford = case unLoc lford of
 217                                       ForeignImport n _ _ -> [found n]
 218                                       ForeignExport { } -> []
 219   in vals ++ tys ++ fors
 220   where dataNames tycon cons = found tycon : map conName cons
 221         conName td = found $ con_name $ unLoc td
 222         found = foundOfLName mod
 223
 224 startOfLocated :: Located a -> SrcLoc
 225 startOfLocated lHs = srcSpanStart $ getLoc lHs
 226
 227 foundOfLName :: ModuleName -> Located Name -> FoundThing
 228 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
 229
 230 boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
 231 boundThings modname lbinding =
 232   let thing = foundOfLName modname
 233   in  case unLoc lbinding of
 234         FunBind { fun_id = id } -> [thing id]
 235         PatBind { pat_lhs = lhs } -> panic "Pattern at top level"
 236         VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
 237         AbsBinds { } -> [] -- nothing interesting in a type abstraction
 238