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           filedata <- mapM (findthings session) filenames
  60           if mode == BothTags || mode == CTags
  61            then do
  62              ctagsfile <- openFile "tags" openFileMode
  63              writectagsfile ctagsfile filedata
  64              hClose ctagsfile
  65            else return ()
  66           if mode == BothTags || mode == ETags
  67            then do
  68              etagsfile <- openFile "TAGS" openFileMode
  69              writeetagsfile etagsfile filedata
  70              hClose etagsfile
  71            else return ()
  72
  73 -- | getMode takes a list of modes and extract the mode with the
  74 --   highest precedence.  These are as follows: Both, CTags, ETags
  75 --   The default case is Both.
  76 getMode :: [Mode] -> Mode
  77 getMode [] = BothTags
  78 getMode [x] = x
  79 getMode (x:xs) = max x (getMode xs)
  80
  81
  82 splitArgs :: [String] -> ([String], [String], Bool)
  83 -- pull out arguments between -- for GHC
  84 splitArgs args = split [] [] False args
  85     where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
  86           split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
  87           split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
  88
  89 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
  90
  91 options :: [OptDescr Mode]
  92 options = [ Option "c" ["ctags"]
  93             (NoArg CTags) "generate CTAGS file (ctags)"
  94           , Option "e" ["etags"]
  95             (NoArg ETags) "generate ETAGS file (etags)"
  96           , Option "b" ["both"]
  97             (NoArg BothTags) ("generate both CTAGS and ETAGS")
  98           , Option "a" ["append"]
  99             (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)")
 100           , Option "h" ["help"] (NoArg Help) "This help"
 101           ]
 102
 103 type FileName = String
 104
 105 type ThingName = String
 106
 107 -- The position of a token or definition
 108 data Pos = Pos
 109                 FileName        -- file name
 110                 Int                     -- line number
 111                 Int             -- token number
 112                 String          -- string that makes up that line
 113         deriving Show
 114
 115 srcLocToPos :: SrcLoc -> Pos
 116 srcLocToPos loc =
 117     Pos (unpackFS $ srcLocFile loc) (srcLocLine loc) (srcLocCol loc) "bogus"
 118
 119 -- A definition we have found
 120 data FoundThing = FoundThing ThingName Pos
 121         deriving Show
 122
 123 -- Data we have obtained from a file
 124 data FileData = FileData FileName [FoundThing]
 125
 126 data Token = Token String Pos
 127         deriving Show
 128
 129
 130 -- stuff for dealing with ctags output format
 131
 132 writectagsfile :: Handle -> [FileData] -> IO ()
 133 writectagsfile ctagsfile filedata = do
 134         let things = concat $ map getfoundthings filedata
 135         mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
 136
 137 getfoundthings :: FileData -> [FoundThing]
 138 getfoundthings (FileData filename things) = things
 139
 140 dumpthing :: FoundThing -> String
 141 dumpthing (FoundThing name (Pos filename line _ _)) =
 142         name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
 143
 144
 145 -- stuff for dealing with etags output format
 146
 147 writeetagsfile :: Handle -> [FileData] -> IO ()
 148 writeetagsfile etagsfile filedata = do
 149         mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
 150
 151 e_dumpfiledata :: FileData -> String
 152 e_dumpfiledata (FileData filename things) =
 153         "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
 154         where
 155                 thingsdump = concat $ map e_dumpthing things
 156                 thingslength = length thingsdump
 157
 158 e_dumpthing :: FoundThing -> String
 159 e_dumpthing (FoundThing name (Pos filename line token fullline)) =
 160         ---- (concat $ take (token + 1) $ spacedwords fullline)
 161         name
 162         ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
 163
 164
 165 -- like "words", but keeping the whitespace, and so letting us build
 166 -- accurate prefixes
 167
 168 spacedwords :: String -> [String]
 169 spacedwords [] = []
 170 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
 171         where
 172                 (blanks,rest) = span Char.isSpace xs
 173                 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
 174
 175
 176 -- Find the definitions in a file
 177
 178 modsummary :: ModuleGraph -> FileName -> Maybe ModSummary
 179 modsummary graph n =
 180   List.find matches graph
 181   where matches ms = n == msHsFilePath ms
 182
 183 modname :: ModSummary -> ModuleName
 184 modname summary = moduleName $ ms_mod $ summary
 185
 186 findthings :: Session -> FileName -> IO FileData
 187 findthings session filename = do
 188   setTargets session [Target (TargetFile filename Nothing) Nothing]
 189   print "set targets"
 190   success <- load session LoadAllTargets  --- bring module graph up to date
 191   case success of
 192     Failed -> do { print "load failed"; return emptyFileData }
 193     Succeeded ->
 194       do print "loaded all targets"
 195          graph <- getModuleGraph session
 196          print "got modules graph"
 197          case  modsummary graph filename of
 198            Nothing -> panic "loaded a module from a file but then could not find its summary"
 199            Just ms -> do
 200              mod <- checkModule session (modname ms)
 201              print "got the module"
 202              case mod of
 203                Nothing -> return emptyFileData
 204                Just m -> case renamedSource m of
 205                            Nothing -> return emptyFileData
 206                            Just s -> return $ fileData filename s
 207   where emptyFileData = FileData filename []
 208
 209
 210 fileData :: FileName -> RenamedSource -> FileData
 211 fileData filename (group, imports, lie) =
 212     -- lie is related to type checking and so is irrelevant
 213     -- imports contains import declarations and no definitions
 214     FileData filename (boundValues group)
 215
 216 boundValues :: HsGroup Name -> [FoundThing]
 217 boundValues group =
 218   let vals = case hs_valds group of
 219                ValBindsOut nest sigs ->
 220                    [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
 221       tys = concat $ map tyBound (hs_tyclds group)
 222             where tyBound ltcd = case unLoc ltcd of
 223                                    ForeignType { tcdLName = n } -> [foundOfLName n]
 224                                    TyData { tcdLName = n } -> [foundOfLName n]
 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
 233 posOfLocated :: Located a -> Pos
 234 posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
 235
 236 foundOfLName :: Located Name -> FoundThing
 237 foundOfLName id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
 238
 239 boundThings :: LHsBind Name -> [FoundThing]
 240 boundThings lbinding =
 241   let thing = foundOfLName
 242   in  case unLoc lbinding of
 243         FunBind { fun_id = id } -> [thing id]
 244         PatBind { pat_lhs = lhs } -> panic "Pattern at top level"
 245         VarBind { var_id = id } -> [FoundThing (getOccString id) (posOfLocated lbinding)]
 246         AbsBinds { } -> [] -- nothing interesting in a type abstraction