utils/ghctags/GhcTags.hs

   1 {-# OPTIONS_GHC -XCPP #-}
   2 module Main where
   3
   4 import GHC
   5 import BasicTypes
   6 import Digraph  ( flattenSCCs )
   7 import DriverPhases ( isHaskellSrcFilename )
   8 import HscTypes (msHsFilePath)
   9 import Name
  10 import Outputable
  11 import ErrUtils ( printBagOfErrors )
  12 import DynFlags(GhcMode, defaultDynFlags)
  13 import SrcLoc
  14 import Bag
  15 import Util ( handle, handleDyn )
  16 import FastString
  17
  18 import Control.Monad
  19 import System.Environment
  20 import System.Console.GetOpt
  21 import System.Exit
  22 import Data.Char
  23 import System.IO
  24 import Data.List as List
  25 import Data.Maybe
  26
  27 -- search for definitions of things
  28 -- we do this by parsing the source and grabbing top-level definitions
  29
  30 -- We generate both CTAGS and ETAGS format tags files
  31 -- The former is for use in most sensible editors, while EMACS uses ETAGS
  32
  33 ----------------------------------
  34 ---- CENTRAL DATA TYPES ----------
  35
  36 type FileName = String
  37 type ThingName = String -- name of a defined entity in a Haskell program
  38
  39 -- A definition we have found (we know its containing module, name, and location)
  40 data FoundThing = FoundThing ModuleName ThingName SrcLoc
  41
  42 -- Data we have obtained from a file (list of things we found)
  43 data FileData = FileData FileName [FoundThing]
  44 --- invariant (not checked): every found thing has a source location in that file?
  45
  46
  47 ------------------------------
  48 -------- MAIN PROGRAM --------
  49
  50 main :: IO ()
  51 main = do
  52         progName <- getProgName
  53         let usageString =
  54               "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]"
  55         args <- getArgs
  56         let (ghcArgs, ourArgs, unbalanced) = splitArgs args
  57         let (flags, filenames, errs) = getOpt Permute options ourArgs
  58         let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames
  59         let ghc_topdir = case [ d | FlagTopDir d <- flags ] of
  60                                 [] -> ""
  61                                 (x:_) -> x
  62         mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n")
  63               otherfiles
  64         if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == []
  65          then do
  66            putStr $ unlines errs
  67            putStr $ usageInfo usageString options
  68            exitWith (ExitFailure 1)
  69          else return ()
  70
  71         let modes = getMode flags
  72         let openFileMode = if elem FlagAppend flags
  73                      then AppendMode
  74                      else WriteMode
  75         ctags_hdl <-  if CTags `elem` modes
  76                            then Just `liftM` openFile "tags" openFileMode
  77                            else return Nothing
  78         etags_hdl <- if ETags `elem` modes
  79                            then Just `liftM` openFile "TAGS" openFileMode
  80                            else return Nothing
  81
  82         GHC.defaultErrorHandler defaultDynFlags $ do
  83           session <- newSession (Just ghc_topdir)
  84           flags <- getSessionDynFlags session
  85           (pflags, _) <- parseDynamicFlags flags{ verbosity=1 } ghcArgs
  86           let flags = pflags { hscTarget = HscNothing } -- don't generate anything
  87           GHC.defaultCleanupHandler flags $ do
  88
  89           setSessionDynFlags session flags
  90           targetsAtOneGo session hsfiles (ctags_hdl,etags_hdl)
  91
  92 ----------------------------------------------
  93 ----------  ARGUMENT PROCESSING --------------
  94
  95 data Flag
  96    = FlagETags
  97    | FlagCTags
  98    | FlagBoth
  99    | FlagAppend
 100    | FlagHelp
 101    | FlagTopDir FilePath
 102   deriving (Ord, Eq, Show)
 103   -- ^Represents options passed to the program
 104
 105 data Mode = ETags | CTags deriving Eq
 106
 107 getMode :: [Flag] -> [Mode]
 108 getMode fs = go (concatMap modeLike fs)
 109  where go []     = [ETags,CTags]
 110        go [x]    = [x]
 111        go more   = nub more
 112
 113        modeLike FlagETags = [ETags]
 114        modeLike FlagCTags = [CTags]
 115        modeLike FlagBoth  = [ETags,CTags]
 116        modeLike _         = []
 117
 118 splitArgs :: [String] -> ([String], [String], Bool)
 119 -- ^Pull out arguments between -- for GHC
 120 splitArgs args = split [] [] False args
 121     where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args
 122           split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args
 123           split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal)
 124
 125 options :: [OptDescr Flag]
 126 -- supports getopt
 127 options = [ Option "" ["topdir"]
 128             (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)"
 129           , Option "c" ["ctags"]
 130             (NoArg FlagCTags) "generate CTAGS file (ctags)"
 131           , Option "e" ["etags"]
 132             (NoArg FlagETags) "generate ETAGS file (etags)"
 133           , Option "b" ["both"]
 134             (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
 135           , Option "a" ["append"]
 136             (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
 137           , Option "h" ["help"] (NoArg FlagHelp) "This help"
 138           ]
 139
 140
 141 ----------------------------------------------------------------
 142 --- LOADING HASKELL SOURCE
 143 --- (these bits actually run the compiler and produce abstract syntax)
 144
 145 safeLoad :: Session -> LoadHowMuch -> IO SuccessFlag
 146 -- like GHC.load, but does not stop process on exception
 147 safeLoad session mode = do
 148   dflags <- getSessionDynFlags session
 149   handle (\exception -> return Failed ) $
 150     handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
 151                           return Failed) $ load session mode
 152
 153
 154 targetsAtOneGo :: Session -> [FileName] -> (Maybe Handle, Maybe Handle) -> IO ()
 155 -- load a list of targets
 156 targetsAtOneGo session hsfiles handles = do
 157   targets <- mapM (\f -> guessTarget f Nothing) hsfiles
 158   setTargets session targets
 159   putStrLn $ "Load it all:"
 160   flag <- load session LoadAllTargets
 161   when (failed flag) $ exitWith (ExitFailure 1)
 162   modgraph <- getModuleGraph session
 163   let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
 164   graphData session mods handles
 165
 166   where targetInfo [hs] = "target " ++ hs
 167         targetInfo hss  = show (length hss) ++ " targets at one go"
 168
 169 fileTarget :: FileName -> Target
 170 fileTarget filename = Target (TargetFile filename Nothing) Nothing
 171
 172 ---------------------------------------------------------------
 173 ----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
 174
 175 graphData :: Session -> ModuleGraph -> (Maybe Handle, Maybe Handle) -> IO ()
 176 graphData session graph handles = do
 177     mapM_ foundthings graph
 178     where foundthings ms =
 179               let filename = msHsFilePath ms
 180                   modname = moduleName $ ms_mod ms
 181               in  do mod <- checkModule session modname False
 182                      let fd = maybe (FileData filename []) id $ do
 183                                 m <- mod
 184                                 s <- renamedSource m
 185                                 return $ fileData filename modname s
 186                      writeTagsData handles fd
 187
 188 fileData :: FileName -> ModuleName -> RenamedSource -> FileData
 189 fileData filename modname (group, _imports, _lie, _doc, _haddock) =
 190     -- lie is related to type checking and so is irrelevant
 191     -- imports contains import declarations and no definitions
 192     -- doc and haddock seem haddock-related; let's hope to ignore them
 193     FileData filename (boundValues modname group)
 194
 195 boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
 196 -- ^Finds all the top-level definitions in a module
 197 boundValues mod group =
 198   let vals = case hs_valds group of
 199                ValBindsOut nest sigs ->
 200                    [ x | (_rec, binds) <- nest, bind <- bagToList binds,
 201                               x <- boundThings mod bind ]
 202       tys = concat $ map tyBound (hs_tyclds group)
 203             where tyBound ltcd = case unLoc ltcd of
 204                                    ForeignType { tcdLName = n } -> [found n]
 205                                    TyData { tcdLName = tycon, tcdCons = cons } ->
 206                                        dataNames tycon cons
 207                                    TySynonym { tcdLName = n } -> [found n]
 208                                    ClassDecl {  tcdLName = n } -> [found n]
 209       fors = concat $ map forBound (hs_fords group)
 210              where forBound lford = case unLoc lford of
 211                                       ForeignImport n _ _ -> [found n]
 212                                       ForeignExport { } -> []
 213   in vals ++ tys ++ fors
 214   where dataNames tycon cons = found tycon : map conName cons
 215         conName td = found $ con_name $ unLoc td
 216         found = foundOfLName mod
 217
 218 startOfLocated :: Located a -> SrcLoc
 219 startOfLocated lHs = srcSpanStart $ getLoc lHs
 220
 221 foundOfLName :: ModuleName -> Located Name -> FoundThing
 222 foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
 223
 224 boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
 225 boundThings modname lbinding =
 226   case unLoc lbinding of
 227     FunBind { fun_id = id } -> [thing id]
 228     PatBind { pat_lhs = lhs } -> patThings lhs []
 229     VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
 230     AbsBinds { } -> [] -- nothing interesting in a type abstraction
 231   where thing = foundOfLName modname
 232         patThings lpat tl =
 233           let loc = startOfLocated lpat
 234               lid id = FoundThing modname (getOccString id) loc
 235           in case unLoc lpat of
 236                WildPat _ -> tl
 237                VarPat name -> lid name : tl
 238                VarPatOut name _ -> lid name : tl -- XXX need help here
 239                LazyPat p -> patThings p tl
 240                AsPat id p -> patThings p (thing id : tl)
 241                ParPat p -> patThings p tl
 242                BangPat p -> patThings p tl
 243                ListPat ps _ -> foldr patThings tl ps
 244                TuplePat ps _ _ -> foldr patThings tl ps
 245                PArrPat ps _ -> foldr patThings tl ps
 246                ConPatIn _ conargs -> conArgs conargs tl
 247                ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
 248                LitPat _ -> tl
 249 #if __GLASGOW_HASKELL__ > 608
 250                NPat _ _ _ -> tl -- form of literal pattern?
 251 #else
 252                NPat _ _ _ _ -> tl -- form of literal pattern?
 253 #endif
 254                NPlusKPat id _ _ _ -> thing id : tl
 255                TypePat _ -> tl -- XXX need help here
 256                SigPatIn p _ -> patThings p tl
 257                SigPatOut p _ -> patThings p tl
 258         conArgs (PrefixCon ps) tl = foldr patThings tl ps
 259         conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
 260              = foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl flds
 261         conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
 262
 263
 264 -- stuff for dealing with ctags output format
 265
 266 writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do
 267   maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl
 268   maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl
 269
 270 writectagsfile :: Handle -> FileData -> IO ()
 271 writectagsfile ctagsfile filedata = do
 272         let things = getfoundthings filedata
 273         mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things
 274         mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True  x) things
 275
 276 getfoundthings :: FileData -> [FoundThing]
 277 getfoundthings (FileData filename things) = things
 278
 279 dumpthing :: Bool -> FoundThing -> String
 280 dumpthing showmod (FoundThing modname name loc) =
 281         fullname ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
 282     where line = srcLocLine loc
 283           filename = unpackFS $ srcLocFile loc
 284           fullname = if showmod then moduleNameString modname ++ "." ++ name
 285                      else name
 286
 287 -- stuff for dealing with etags output format
 288
 289 writeetagsfile :: Handle -> FileData -> IO ()
 290 writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
 291
 292 e_dumpfiledata :: FileData -> String
 293 e_dumpfiledata (FileData filename things) =
 294         "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
 295         where
 296                 thingsdump = concat $ map e_dumpthing things
 297                 thingslength = length thingsdump
 298
 299 e_dumpthing :: FoundThing -> String
 300 e_dumpthing (FoundThing modname name loc) =
 301     tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
 302     where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
 303           line = srcLocLine loc