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         args <- getArgs
  35         let usageString = "Usage: " ++ progName ++ " [OPTION...] [files...]"
  36         let (modes, filenames, errs) = getOpt Permute options args
  37         if errs /= [] || elem Help modes || filenames == []
  38          then do
  39            putStr $ unlines errs
  40            putStr $ usageInfo usageString options
  41            exitWith (ExitFailure 1)
  42          else return ()
  43         let mode = getMode (Append `delete` modes)
  44         let openFileMode = if elem Append modes
  45                            then AppendMode
  46                            else WriteMode
  47         GHC.init (Just "/usr/local/lib/ghc-6.5")
  48         GHC.defaultErrorHandler defaultDynFlags $ do
  49           session <- newSession JustTypecheck
  50           print "created a session"
  51           flags <- getSessionDynFlags session
  52           (flags, _) <- parseDynamicFlags flags ["-package", "ghc"]
  53           GHC.defaultCleanupHandler flags $ do
  54             flags <- initPackages flags
  55             setSessionDynFlags session flags
  56           filedata <- mapM (findthings session) filenames
  57           if mode == BothTags || mode == CTags
  58            then do
  59              ctagsfile <- openFile "tags" openFileMode
  60              writectagsfile ctagsfile filedata
  61              hClose ctagsfile
  62            else return ()
  63           if mode == BothTags || mode == ETags
  64            then do
  65              etagsfile <- openFile "TAGS" openFileMode
  66              writeetagsfile etagsfile filedata
  67              hClose etagsfile
  68            else return ()
  69
  70 -- | getMode takes a list of modes and extract the mode with the
  71 --   highest precedence.  These are as follows: Both, CTags, ETags
  72 --   The default case is Both.
  73 getMode :: [Mode] -> Mode
  74 getMode [] = BothTags
  75 getMode [x] = x
  76 getMode (x:xs) = max x (getMode xs)
  77
  78
  79 data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show)
  80
  81 options :: [OptDescr Mode]
  82 options = [ Option "c" ["ctags"]
  83             (NoArg CTags) "generate CTAGS file (ctags)"
  84           , Option "e" ["etags"]
  85             (NoArg ETags) "generate ETAGS file (etags)"
  86           , Option "b" ["both"]
  87             (NoArg BothTags) ("generate both CTAGS and ETAGS")
  88           , Option "a" ["append"]
  89             (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)")
  90           , Option "h" ["help"] (NoArg Help) "This help"
  91           ]
  92
  93 type FileName = String
  94
  95 type ThingName = String
  96
  97 -- The position of a token or definition
  98 data Pos = Pos
  99                 FileName        -- file name
 100                 Int                     -- line number
 101                 Int             -- token number
 102                 String          -- string that makes up that line
 103         deriving Show
 104
 105 srcLocToPos :: SrcLoc -> Pos
 106 srcLocToPos loc =
 107     Pos (unpackFS $ srcLocFile loc) (srcLocLine loc) (srcLocCol loc) "bogus"
 108
 109 -- A definition we have found
 110 data FoundThing = FoundThing ThingName Pos
 111         deriving Show
 112
 113 -- Data we have obtained from a file
 114 data FileData = FileData FileName [FoundThing]
 115
 116 data Token = Token String Pos
 117         deriving Show
 118
 119
 120 -- stuff for dealing with ctags output format
 121
 122 writectagsfile :: Handle -> [FileData] -> IO ()
 123 writectagsfile ctagsfile filedata = do
 124         let things = concat $ map getfoundthings filedata
 125         mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
 126
 127 getfoundthings :: FileData -> [FoundThing]
 128 getfoundthings (FileData filename things) = things
 129
 130 dumpthing :: FoundThing -> String
 131 dumpthing (FoundThing name (Pos filename line _ _)) =
 132         name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
 133
 134
 135 -- stuff for dealing with etags output format
 136
 137 writeetagsfile :: Handle -> [FileData] -> IO ()
 138 writeetagsfile etagsfile filedata = do
 139         mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
 140
 141 e_dumpfiledata :: FileData -> String
 142 e_dumpfiledata (FileData filename things) =
 143         "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
 144         where
 145                 thingsdump = concat $ map e_dumpthing things
 146                 thingslength = length thingsdump
 147
 148 e_dumpthing :: FoundThing -> String
 149 e_dumpthing (FoundThing name (Pos filename line token fullline)) =
 150         ---- (concat $ take (token + 1) $ spacedwords fullline)
 151         name
 152         ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
 153
 154
 155 -- like "words", but keeping the whitespace, and so letting us build
 156 -- accurate prefixes
 157
 158 spacedwords :: String -> [String]
 159 spacedwords [] = []
 160 spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
 161         where
 162                 (blanks,rest) = span Char.isSpace xs
 163                 (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
 164
 165
 166 -- Find the definitions in a file
 167
 168 modsummary :: ModuleGraph -> FileName -> Maybe ModSummary
 169 modsummary graph n =
 170   List.find matches graph
 171   where matches ms = n == msHsFilePath ms
 172
 173 modname :: ModSummary -> ModuleName
 174 modname summary = moduleName $ ms_mod $ summary
 175
 176 findthings :: Session -> FileName -> IO FileData
 177 findthings session filename = do
 178   setTargets session [Target (TargetFile filename Nothing) Nothing]
 179   print "set targets"
 180   success <- load session LoadAllTargets  --- bring module graph up to date
 181   case success of
 182     Failed -> do { print "load failed"; return emptyFileData }
 183     Succeeded ->
 184       do print "loaded all targets"
 185          graph <- getModuleGraph session
 186          print "got modules graph"
 187          case  modsummary graph filename of
 188            Nothing -> panic "loaded a module from a file but then could not find its summary"
 189            Just ms -> do
 190              mod <- checkModule session (modname ms)
 191              print "got the module"
 192              case mod of
 193                Nothing -> return emptyFileData
 194                Just m -> case renamedSource m of
 195                            Nothing -> return emptyFileData
 196                            Just s -> return $ fileData filename s
 197   where emptyFileData = FileData filename []
 198
 199
 200 fileData :: FileName -> RenamedSource -> FileData
 201 fileData filename (group, imports, lie) =
 202     -- lie is related to type checking and so is irrelevant
 203     -- imports contains import declarations and no definitions
 204     FileData filename (boundValues group)
 205
 206 boundValues :: HsGroup Name -> [FoundThing]
 207 boundValues group =
 208   case hs_valds group of
 209     ValBindsOut nest sigs ->
 210         [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
 211
 212 posOfLocated :: Located a -> Pos
 213 posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
 214
 215 boundThings :: LHsBind Name -> [FoundThing]
 216 boundThings lbinding =
 217   let thing id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
 218   in  case unLoc lbinding of
 219         FunBind { fun_id = id } -> [thing id]
 220         PatBind { pat_lhs = lhs } -> patBoundIds lhs
 221 --        VarBind { var_id = id } -> [thing id]
 222         _ -> []
 223
 224
 225 patBoundIds :: a -> b
 226 patBoundIds _ = panic "not on your life"
 227
 228 -- actually pick up definitions
 229
 230 findstuff :: [Token] -> [FoundThing]
 231 findstuff ((Token "data" _):(Token name pos):xs) =
 232         FoundThing name pos : (getcons xs) ++ (findstuff xs)
 233 findstuff ((Token "newtype" _):(Token name pos):xs) =
 234         FoundThing name pos : findstuff xs
 235 findstuff ((Token "type" _):(Token name pos):xs) =
 236         FoundThing name pos : findstuff xs
 237 findstuff ((Token name pos):(Token "::" _):xs) =
 238         FoundThing name pos : findstuff xs
 239 findstuff (x:xs) = findstuff xs
 240 findstuff [] = []
 241
 242
 243 -- get the constructor definitions, knowing that a datatype has just started
 244
 245 getcons :: [Token] -> [FoundThing]
 246 getcons ((Token "=" _):(Token name pos):xs) =
 247         FoundThing name pos : getcons2 xs
 248 getcons (x:xs) = getcons xs
 249 getcons [] = []
 250
 251
 252 getcons2 ((Token "=" _):xs) = []
 253 getcons2 ((Token "|" _):(Token name pos):xs) =
 254         FoundThing name pos : getcons2 xs
 255 getcons2 (x:xs) = getcons2 xs
 256 getcons2 [] = []
 257