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 -- The position of a token or definition
 117 data Pos = Pos
 118                 FileName        -- file name
 119                 Int                     -- line number
 120                 Int             -- token number
 121                 String          -- string that makes up that line
 122         deriving Show
 123
 124 srcLocToPos :: SrcLoc -> Pos
 125 srcLocToPos loc =
 126     Pos (unpackFS $ srcLocFile loc) (srcLocLine loc) (srcLocCol loc) "bogus"
 127
 128 -- A definition we have found
 129 data FoundThing = FoundThing ThingName Pos
 130         deriving Show
 131
 132 -- Data we have obtained from a file
 133 data FileData = FileData FileName [FoundThing]
 134
 135 data Token = Token String Pos
 136         deriving Show
 137
 138
 139 -- stuff for dealing with ctags output format
 140
 141 writectagsfile :: Handle -> [FileData] -> IO ()
 142 writectagsfile ctagsfile filedata = do
 143         let things = concat $ map getfoundthings filedata
 144         mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
 145
 146 getfoundthings :: FileData -> [FoundThing]
 147 getfoundthings (FileData filename things) = things
 148
 149 dumpthing :: FoundThing -> String
 150 dumpthing (FoundThing name (Pos filename line _ _)) =
 151         name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
 152
 153
 154 -- stuff for dealing with etags output format
 155
 156 writeetagsfile :: Handle -> [FileData] -> IO ()
 157 writeetagsfile etagsfile filedata = do
 158         mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
 159
 160 e_dumpfiledata :: FileData -> String
 161 e_dumpfiledata (FileData filename things) =
 162         "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
 163         where
 164                 thingsdump = concat $ map e_dumpthing things
 165                 thingslength = length thingsdump
 166
 167 e_dumpthing :: FoundThing -> String
 168 e_dumpthing (FoundThing name (Pos filename line token fullline)) =
 169         ---- (concat $ take (token + 1) $ spacedwords fullline)
 170         name
 171         ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
 172
 173
 174 -- like "words", but keeping the whitespace, and so letting us build
 175 -- accurate prefixes
 176
 177 spacedwords :: String -> [String]
 178 spacedwords [] = []
 179 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
 180         where
 181                 (blanks,rest) = span Char.isSpace xs
 182                 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
 183
 184
 185 -- Find the definitions in a file
 186
 187 modsummary :: ModuleGraph -> FileName -> Maybe ModSummary
 188 modsummary graph n =
 189   List.find matches graph
 190   where matches ms = n == msHsFilePath ms
 191
 192 modname :: ModSummary -> ModuleName
 193 modname summary = moduleName $ ms_mod $ summary
 194
 195 fileTarget :: FileName -> Target
 196 fileTarget filename = Target (TargetFile filename Nothing) Nothing
 197
 198 graphData :: Session -> ModuleGraph -> IO [FileData]
 199 graphData session graph =
 200     mapM foundthings graph
 201     where foundthings ms =
 202               let filename = msHsFilePath ms
 203               in  do mod <- checkModule session (moduleName $ ms_mod ms)
 204                      return $ maybe (FileData filename []) id $ do
 205                        m <- mod
 206                        s <- renamedSource m
 207                        return $ fileData filename s
 208
 209 fileData :: FileName -> RenamedSource -> FileData
 210 fileData filename (group, imports, lie) =
 211     -- lie is related to type checking and so is irrelevant
 212     -- imports contains import declarations and no definitions
 213     FileData filename (boundValues group)
 214
 215 boundValues :: HsGroup Name -> [FoundThing]
 216 boundValues group =
 217   let vals = case hs_valds group of
 218                ValBindsOut nest sigs ->
 219                    [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
 220       tys = concat $ map tyBound (hs_tyclds group)
 221             where tyBound ltcd = case unLoc ltcd of
 222                                    ForeignType { tcdLName = n } -> [foundOfLName n]
 223                                    TyData { tcdLName = tycon, tcdCons = cons } ->
 224                                        dataNames tycon cons
 225                                    TySynonym { tcdLName = n } -> [foundOfLName n]
 226                                    ClassDecl {  tcdLName = n } -> [foundOfLName n]
 227       fors = concat $ map forBound (hs_fords group)
 228              where forBound lford = case unLoc lford of
 229                                       ForeignImport n _ _ -> [foundOfLName n]
 230                                       ForeignExport { } -> []
 231   in vals ++ tys ++ fors
 232   where dataNames tycon cons = foundOfLName tycon : map conName cons
 233         conName td = foundOfLName $ con_name $ unLoc td
 234
 235 posOfLocated :: Located a -> Pos
 236 posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
 237
 238 foundOfLName :: Located Name -> FoundThing
 239 foundOfLName id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
 240
 241 boundThings :: LHsBind Name -> [FoundThing]
 242 boundThings lbinding =
 243   let thing = foundOfLName
 244   in  case unLoc lbinding of
 245         FunBind { fun_id = id } -> [thing id]
 246         PatBind { pat_lhs = lhs } -> panic "Pattern at top level"
 247         VarBind { var_id = id } -> [FoundThing (getOccString id) (posOfLocated lbinding)]
 248         AbsBinds { } -> [] -- nothing interesting in a type abstraction
 249