utils/ghctags/GhcTags.hs

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