utils/ghctags/Main.hs

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