utils/ghctags/GhcTags.hs

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