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