X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghctags%2FGhcTags.hs;h=e74b2d18013fd8f96052b4c24a01dd04edabe522;hb=34cc75e1a62638f2833815746ebce0a9114dc26b;hp=86883f1a05fbc866346a23457312aba69c5d07d3;hpb=abbe21f2e8109448c31422766c6777ebc9ce0cd0;p=ghc-hetmet.git diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs index 86883f1..e74b2d1 100644 --- a/utils/ghctags/GhcTags.hs +++ b/utils/ghctags/GhcTags.hs @@ -1,22 +1,43 @@ +{-# OPTIONS_GHC -XCPP -XPatternGuards -XScopedTypeVariables -Wall #-} module Main where + +import Prelude hiding ( mod, id, mapM ) +import GHC hiding (flags) +--import Packages +import HscTypes ( isBootSummary ) +import BasicTypes +import Digraph ( flattenSCCs ) +import DriverPhases ( isHaskellSrcFilename ) +import HscTypes ( msHsFilePath ) +import Name ( getOccString ) +--import ErrUtils ( printBagOfErrors ) +import DynFlags ( defaultDynFlags ) +import SrcLoc import Bag -import Char -import DriverPhases ( isHaskellSrcFilename ) -import DynFlags(GhcMode, defaultDynFlags) -import ErrUtils ( printBagOfErrors ) +import Exception -- ( ghandle ) import FastString -import GHC -import HscTypes (msHsFilePath) -import IO -import List -import Maybe -import Name -import Outputable -import SrcLoc +import MonadUtils ( liftIO ) + +-- Every GHC comes with Cabal anyways, so this is not a bad new dependency +import Distribution.Simple.GHC ( ghcOptions ) +import Distribution.Simple.Configure ( getPersistBuildConfig ) +import Distribution.PackageDescription ( library, libBuildInfo ) +import Distribution.Simple.LocalBuildInfo ( localPkgDescr, buildDir ) + +import Control.Monad hiding (mapM) import System.Environment import System.Console.GetOpt import System.Exit -import Util ( handle, handleDyn ) +import Data.Char +import System.IO +import Data.List as List hiding ( group ) +import Data.Maybe +import Data.Traversable (mapM) +import Data.Map ( Map ) +import qualified Data.Map as M + +--import UniqFM +--import Debug.Trace -- search for definitions of things -- we do this by parsing the source and grabbing top-level definitions @@ -24,12 +45,6 @@ import Util ( handle, handleDyn ) -- We generate both CTAGS and ETAGS format tags files -- The former is for use in most sensible editors, while EMACS uses ETAGS ---------------------------------- ---------- CONFIGURATION --------- - -ghcRootDir = "/usr/local/lib/ghc-6.5" --- root for -package ghc? (passed to GHC.init) - - ---------------------------------- ---- CENTRAL DATA TYPES ---------- @@ -40,7 +55,7 @@ type ThingName = String -- name of a defined entity in a Haskell program data FoundThing = FoundThing ModuleName ThingName SrcLoc -- Data we have obtained from a file (list of things we found) -data FileData = FileData FileName [FoundThing] +data FileData = FileData FileName [FoundThing] (Map Int String) --- invariant (not checked): every found thing has a source location in that file? @@ -49,151 +64,199 @@ data FileData = FileData FileName [FoundThing] main :: IO () main = do - progName <- getProgName - let usageString = - "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]" - args <- getArgs - let (ghcArgs, ourArgs, unbalanced) = splitArgs args - let (modes, filenames, errs) = getOpt Permute options ourArgs - let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames - mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n") - otherfiles - if unbalanced || errs /= [] || elem Help modes || hsfiles == [] - then do - putStr $ unlines errs - putStr $ usageInfo usageString options - exitWith (ExitFailure 1) - else return () - GHC.defaultErrorHandler defaultDynFlags $ do - session <- newSession JustTypecheck (Just ghcRootDir) - flags <- getSessionDynFlags session - (pflags, _) <- parseDynamicFlags flags ghcArgs - let flags = pflags { hscTarget = HscNothing } -- don't generate anything - GHC.defaultCleanupHandler flags $ do - setSessionDynFlags session flags - -- targets <- mapM (\s -> guessTarget s Nothing) hsfiles - -- guessTarget would be more compatible with ghc -M - filedata <- targetsAtOneGo session hsfiles - filedata <- case filedata of - Just fd -> return fd - Nothing -> targetsOneAtATime session hsfiles - emitTagsData modes filedata + progName <- getProgName + let usageString = + "Usage: " ++ progName ++ " [OPTION...] [-- GHC OPTION... --] [files...]" + args <- getArgs + let (ghcArgs', ourArgs, unbalanced) = splitArgs args + let (flags, filenames, errs) = getOpt Permute options ourArgs + let (hsfiles, otherfiles) = List.partition isHaskellSrcFilename filenames + + let ghc_topdir = case [ d | FlagTopDir d <- flags ] of + [] -> "" + (x:_) -> x + mapM_ (\n -> putStr $ "Warning: ignoring non-Haskellish file " ++ n ++ "\n") + otherfiles + if unbalanced || errs /= [] || elem FlagHelp flags || hsfiles == [] + then do + putStr $ unlines errs + putStr $ usageInfo usageString options + exitWith (ExitFailure 1) + else return () + ghcArgs <- case [ d | FlagUseCabalConfig d <- flags ] of + [distPref] -> do + cabalOpts <- flagsFromCabal distPref + return (ghcArgs' ++ cabalOpts) + [] -> + return ghcArgs' + _ -> error "Too many --use-cabal-config flags" + print ghcArgs + + let modes = getMode flags + let openFileMode = if elem FlagAppend flags + then AppendMode + else WriteMode + ctags_hdl <- if CTags `elem` modes + then Just `liftM` openFile "tags" openFileMode + else return Nothing + etags_hdl <- if ETags `elem` modes + then Just `liftM` openFile "TAGS" openFileMode + else return Nothing + + GHC.defaultErrorHandler defaultDynFlags $ + runGhc (Just ghc_topdir) $ do + --liftIO $ print "starting up session" + dflags <- getSessionDynFlags + (pflags, unrec, warns) <- parseDynamicFlags dflags{ verbosity=1 } + (map noLoc ghcArgs) + unless (null unrec) $ + liftIO $ putStrLn $ "Unrecognised options:\n" ++ show (map unLoc unrec) + liftIO $ mapM_ putStrLn (map unLoc warns) + let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything + -- liftIO $ print ("pkgDB", case (pkgDatabase dflags2) of Nothing -> 0 + -- Just m -> sizeUFM m) + setSessionDynFlags dflags2 + --liftIO $ print (length pkgs) + + GHC.defaultCleanupHandler dflags2 $ do + + targetsAtOneGo hsfiles (ctags_hdl,etags_hdl) + mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl] ---------------------------------------------- ---------- ARGUMENT PROCESSING -------------- -data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show) +data Flag + = FlagETags + | FlagCTags + | FlagBoth + | FlagAppend + | FlagHelp + | FlagTopDir FilePath + | FlagUseCabalConfig FilePath + | FlagFilesFromCabal + deriving (Ord, Eq, Show) -- ^Represents options passed to the program --- | getMode takes a list of modes and extract the mode with the --- highest precedence. These are as follows: Both, CTags, ETags --- The default case is Both. -getMode :: [Mode] -> Mode -getMode [] = BothTags -getMode [x] = x -getMode (x:xs) = max x (getMode xs) +data Mode = ETags | CTags deriving Eq + +getMode :: [Flag] -> [Mode] +getMode fs = go (concatMap modeLike fs) + where go [] = [ETags,CTags] + go [x] = [x] + go more = nub more + modeLike FlagETags = [ETags] + modeLike FlagCTags = [CTags] + modeLike FlagBoth = [ETags,CTags] + modeLike _ = [] splitArgs :: [String] -> ([String], [String], Bool) -- ^Pull out arguments between -- for GHC -splitArgs args = split [] [] False args +splitArgs args0 = split [] [] False args0 where split ghc' tags' unbal ("--" : args) = split tags' ghc' (not unbal) args split ghc' tags' unbal (arg : args) = split ghc' (arg:tags') unbal args split ghc' tags' unbal [] = (reverse ghc', reverse tags', unbal) -options :: [OptDescr Mode] +options :: [OptDescr Flag] -- supports getopt -options = [ Option "c" ["ctags"] - (NoArg CTags) "generate CTAGS file (ctags)" +options = [ Option "" ["topdir"] + (ReqArg FlagTopDir "DIR") "root of GHC installation (optional)" + , Option "c" ["ctags"] + (NoArg FlagCTags) "generate CTAGS file (ctags)" , Option "e" ["etags"] - (NoArg ETags) "generate ETAGS file (etags)" + (NoArg FlagETags) "generate ETAGS file (etags)" , Option "b" ["both"] - (NoArg BothTags) ("generate both CTAGS and ETAGS") + (NoArg FlagBoth) ("generate both CTAGS and ETAGS") , Option "a" ["append"] - (NoArg Append) ("append to existing CTAGS and/or ETAGS file(s)") - , Option "h" ["help"] (NoArg Help) "This help" + (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)") + , Option "" ["use-cabal-config"] + (ReqArg FlagUseCabalConfig "DIR") "use local cabal configuration from dist dir" + , Option "" ["files-from-cabal"] + (NoArg FlagFilesFromCabal) "use files from cabal" + , Option "h" ["help"] (NoArg FlagHelp) "This help" ] +flagsFromCabal :: FilePath -> IO [String] +flagsFromCabal distPref = do + lbi <- getPersistBuildConfig distPref + let pd = localPkgDescr lbi + case library pd of + Nothing -> error "no library" + Just lib -> + let bi = libBuildInfo lib + odir = buildDir lbi + opts = ghcOptions lbi bi odir + in return opts ---------------------------------------------------------------- --- LOADING HASKELL SOURCE --- (these bits actually run the compiler and produce abstract syntax) -safeLoad :: Session -> LoadHowMuch -> IO SuccessFlag +safeLoad :: LoadHowMuch -> Ghc SuccessFlag -- like GHC.load, but does not stop process on exception -safeLoad session mode = do - dflags <- getSessionDynFlags session - handle (\exception -> return Failed ) $ - handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn) - return Failed) $ load session mode +safeLoad mode = do + _dflags <- getSessionDynFlags + ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $ + handleSourceError (\e -> printExceptionAndWarnings e >> return Failed) $ + load mode -targetsAtOneGo :: Session -> [FileName] -> IO (Maybe [FileData]) +targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc () -- load a list of targets -targetsAtOneGo session hsfiles = do - let targets = map fileTarget hsfiles - setTargets session targets - print $ "trying " ++ targetInfo hsfiles - success <- safeLoad session LoadAllTargets --- bring module graph up to date - case success of - Failed -> return Nothing - Succeeded -> do - print $ "loaded " ++ targetInfo hsfiles - graph <- getModuleGraph session - print "got modules graph" - fd <- graphData session graph - return $ Just fd - - where targetInfo [hs] = "target " ++ hs - targetInfo hss = show (length hss) ++ " targets at one go" - -targetsOneAtATime :: Session -> [FileName] -> IO ([FileData]) --- load a list of targets, one at a time (more resilient to errors) -targetsOneAtATime session hsfiles = do - print "trying targets one by one" - results <- mapM (targetsAtOneGo session) [[f] | f <- hsfiles] - return $ List.concat $ catMaybes results - +targetsAtOneGo hsfiles handles = do + targets <- mapM (\f -> guessTarget f Nothing) hsfiles + setTargets targets + modgraph <- depanal [] False + let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing + graphData mods handles + fileTarget :: FileName -> Target -fileTarget filename = Target (TargetFile filename Nothing) Nothing +fileTarget filename = Target (TargetFile filename Nothing) True Nothing --------------------------------------------------------------- ----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS ----- -graphData :: Session -> ModuleGraph -> IO [FileData] -graphData session graph = - mapM foundthings graph +graphData :: ModuleGraph -> (Maybe Handle, Maybe Handle) -> Ghc () +graphData graph handles = do + mapM_ foundthings graph where foundthings ms = let filename = msHsFilePath ms modname = moduleName $ ms_mod ms - in do mod <- checkModule session modname - return $ maybe (FileData filename []) id $ do - m <- mod - s <- renamedSource m - return $ fileData filename modname s - -fileData :: FileName -> ModuleName -> RenamedSource -> FileData -fileData filename modname (group, _imports, _lie, _doc, _haddock) = + in handleSourceError (\e -> do + printExceptionAndWarnings e + liftIO $ exitWith (ExitFailure 1)) $ + do liftIO $ putStrLn ("loading " ++ filename) + mod <- loadModule =<< typecheckModule =<< parseModule ms + case mod of + _ | isBootSummary ms -> return () + _ | Just s <- renamedSource mod -> + liftIO (writeTagsData handles =<< fileData filename modname s) + _otherwise -> + liftIO $ exitWith (ExitFailure 1) + +fileData :: FileName -> ModuleName -> RenamedSource -> IO FileData +fileData filename modname (group, _imports, _lie, _doc, _haddock) = do -- lie is related to type checking and so is irrelevant -- imports contains import declarations and no definitions -- doc and haddock seem haddock-related; let's hope to ignore them - FileData filename (boundValues modname group) + ls <- lines `fmap` readFile filename + let line_map = M.fromAscList $ zip [1..] ls + evaluate line_map + return $ FileData filename (boundValues modname group) line_map boundValues :: ModuleName -> HsGroup Name -> [FoundThing] -- ^Finds all the top-level definitions in a module boundValues mod group = let vals = case hs_valds group of - ValBindsOut nest sigs -> - [ x | (_rec, binds) <- nest, bind <- bagToList binds, - x <- boundThings mod bind ] - tys = concat $ map tyBound (hs_tyclds group) - where tyBound ltcd = case unLoc ltcd of - ForeignType { tcdLName = n } -> [found n] - TyData { tcdLName = tycon, tcdCons = cons } -> - dataNames tycon cons - TySynonym { tcdLName = n } -> [found n] - ClassDecl { tcdLName = n } -> [found n] + ValBindsOut nest _sigs -> + [ x | (_rec, binds) <- nest + , bind <- bagToList binds + , x <- boundThings mod bind ] + _other -> error "boundValues" + tys = [ n | ns <- map (tyClDeclNames . unLoc) (hs_tyclds group) + , n <- map found ns ] fors = concat $ map forBound (hs_fords group) where forBound lford = case unLoc lford of ForeignImport n _ _ -> [found n] @@ -234,54 +297,41 @@ boundThings modname lbinding = ConPatIn _ conargs -> conArgs conargs tl ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl LitPat _ -> tl +#if __GLASGOW_HASKELL__ > 608 + NPat _ _ _ -> tl -- form of literal pattern? +#else NPat _ _ _ _ -> tl -- form of literal pattern? +#endif NPlusKPat id _ _ _ -> thing id : tl TypePat _ -> tl -- XXX need help here SigPatIn p _ -> patThings p tl SigPatOut p _ -> patThings p tl - DictPat _ _ -> tl + _ -> error "boundThings" conArgs (PrefixCon ps) tl = foldr patThings tl ps - conArgs (RecCon pairs) tl = foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl pairs + conArgs (RecCon (HsRecFields { rec_flds = flds })) tl + = foldr (\f tl' -> patThings (hsRecFieldArg f) tl') tl flds conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl ------------------------------------------------ -------- WRITING THE DATA TO TAGS FILES -------- - -emitTagsData :: [Mode] -> [FileData] -> IO () -emitTagsData modes filedata = do - let mode = getMode (Append `delete` modes) - let openFileMode = if elem Append modes - then AppendMode - else WriteMode - if mode == BothTags || mode == CTags - then do - ctagsfile <- openFile "tags" openFileMode - writectagsfile ctagsfile filedata - hClose ctagsfile - else return () - if mode == BothTags || mode == ETags - then do - etagsfile <- openFile "TAGS" openFileMode - writeetagsfile etagsfile filedata - hClose etagsfile - else return () - - -- stuff for dealing with ctags output format -writectagsfile :: Handle -> [FileData] -> IO () +writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO () +writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do + maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl + maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl + +writectagsfile :: Handle -> FileData -> IO () writectagsfile ctagsfile filedata = do - let things = concat $ map getfoundthings filedata + let things = getfoundthings filedata mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing False x) things mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True x) things getfoundthings :: FileData -> [FoundThing] -getfoundthings (FileData filename things) = things +getfoundthings (FileData _filename things _src_lines) = things dumpthing :: Bool -> FoundThing -> String dumpthing showmod (FoundThing modname name loc) = - fullname ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1) + fullname ++ "\t" ++ filename ++ "\t" ++ (show line) where line = srcLocLine loc filename = unpackFS $ srcLocFile loc fullname = if showmod then moduleNameString modname ++ "." ++ name @@ -289,19 +339,25 @@ dumpthing showmod (FoundThing modname name loc) = -- stuff for dealing with etags output format -writeetagsfile :: Handle -> [FileData] -> IO () -writeetagsfile etagsfile filedata = do - mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata +writeetagsfile :: Handle -> FileData -> IO () +writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata e_dumpfiledata :: FileData -> String -e_dumpfiledata (FileData filename things) = +e_dumpfiledata (FileData filename things line_map) = "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump where - thingsdump = concat $ map e_dumpthing things + thingsdump = concat $ map (e_dumpthing line_map) things thingslength = length thingsdump -e_dumpthing :: FoundThing -> String -e_dumpthing (FoundThing modname name loc) = +e_dumpthing :: Map Int String -> FoundThing -> String +e_dumpthing src_lines (FoundThing modname name loc) = tagline name ++ tagline (moduleNameString modname ++ "." ++ name) - where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n" + where tagline n = src_code ++ "\x7f" + ++ n ++ "\x01" + ++ (show line) ++ "," ++ (show $ column) ++ "\n" line = srcLocLine loc + column = srcLocCol loc + src_code = case M.lookup line src_lines of + Just l -> take (column + length name) l + Nothing -> --trace (show ("not found: ", moduleNameString modname, name, line, column)) + name