utils/ghctags/GhcTags.hs

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