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