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