utils/ghctags/GhcTags.hs

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