utils/ghctags/GhcTags.hs

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