From: Simon Marlow Date: Mon, 25 Jun 2007 13:21:58 +0000 (+0000) Subject: merged patches relating to GhcTags from #946 X-Git-Tag: 2007-11-11~40 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=abbe21f2e8109448c31422766c6777ebc9ce0cd0;p=ghc-hetmet.git merged patches relating to GhcTags from #946 * accomodate changes in the GHC API * refactoring for more readable source code * if the whole group fails, try one file at a time * desperate attempts to handle the GHC build --- diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs index fb79a6a..86883f1 100644 --- a/utils/ghctags/GhcTags.hs +++ b/utils/ghctags/GhcTags.hs @@ -1,19 +1,22 @@ module Main where import Bag import Char +import DriverPhases ( isHaskellSrcFilename ) import DynFlags(GhcMode, defaultDynFlags) +import ErrUtils ( printBagOfErrors ) import FastString import GHC import HscTypes (msHsFilePath) -import List import IO +import List +import Maybe import Name import Outputable import SrcLoc import System.Environment import System.Console.GetOpt import System.Exit - +import Util ( handle, handleDyn ) -- search for definitions of things -- we do this by parsing the source and grabbing top-level definitions @@ -21,12 +24,28 @@ import System.Exit -- We generate both CTAGS and ETAGS format tags files -- The former is for use in most sensible editors, while EMACS uses ETAGS -{- -placateGhc :: IO () -placateGhc = defaultErrorHandler defaultDynFlags $ do - GHC.init (Just "/usr/local/lib/ghc-6.5") -- or your build tree! - s <- newSession mode --} +--------------------------------- +--------- CONFIGURATION --------- + +ghcRootDir = "/usr/local/lib/ghc-6.5" --- root for -package ghc? (passed to GHC.init) + + +---------------------------------- +---- CENTRAL DATA TYPES ---------- + +type FileName = String +type ThingName = String -- name of a defined entity in a Haskell program + +-- A definition we have found (we know its containing module, name, and location) +data FoundThing = FoundThing ModuleName ThingName SrcLoc + +-- Data we have obtained from a file (list of things we found) +data FileData = FileData FileName [FoundThing] +--- invariant (not checked): every found thing has a source location in that file? + + +------------------------------ +-------- MAIN PROGRAM -------- main :: IO () main = do @@ -36,48 +55,36 @@ main = do args <- getArgs let (ghcArgs, ourArgs, unbalanced) = splitArgs args let (modes, filenames, errs) = getOpt Permute options ourArgs - if unbalanced || errs /= [] || elem Help modes || filenames == [] + 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 () - let mode = getMode (Append `delete` modes) - let openFileMode = if elem Append modes - then AppendMode - else WriteMode - GHC.init (Just "/usr/local/lib/ghc-6.5") GHC.defaultErrorHandler defaultDynFlags $ do - session <- newSession JustTypecheck - print "created a session" + session <- newSession JustTypecheck (Just ghcRootDir) flags <- getSessionDynFlags session (pflags, _) <- parseDynamicFlags flags ghcArgs - let flags = pflags { hscTarget = HscNothing } + let flags = pflags { hscTarget = HscNothing } -- don't generate anything GHC.defaultCleanupHandler flags $ do - flags <- initPackages flags setSessionDynFlags session flags - setTargets session (map fileTarget filenames) - print "set targets" - success <- load session LoadAllTargets --- bring module graph up to date - filedata <- case success of - Failed -> do { putStr "Load failed"; exitWith (ExitFailure 2) } - Succeeded -> do - print "loaded all targets" - graph <- getModuleGraph session - print "got modules graph" - graphData session graph - 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 () + -- 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 + + +---------------------------------------------- +---------- ARGUMENT PROCESSING -------------- + +data Mode = ETags | CTags | BothTags | Append | Help 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 @@ -89,15 +96,14 @@ getMode (x:xs) = max x (getMode xs) splitArgs :: [String] -> ([String], [String], Bool) --- pull out arguments between -- for GHC +-- ^Pull out arguments between -- for GHC splitArgs args = split [] [] False args 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) -data Mode = ETags | CTags | BothTags | Append | Help deriving (Ord, Eq, Show) - options :: [OptDescr Mode] +-- supports getopt options = [ Option "c" ["ctags"] (NoArg CTags) "generate CTAGS file (ctags)" , Option "e" ["etags"] @@ -109,78 +115,52 @@ options = [ Option "c" ["ctags"] , Option "h" ["help"] (NoArg Help) "This help" ] -type FileName = String -type ThingName = String +---------------------------------------------------------------- +--- LOADING HASKELL SOURCE +--- (these bits actually run the compiler and produce abstract syntax) --- A definition we have found -data FoundThing = FoundThing ModuleName ThingName SrcLoc +safeLoad :: Session -> LoadHowMuch -> IO 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 --- Data we have obtained from a file -data FileData = FileData FileName [FoundThing] --- stuff for dealing with ctags output format - -writectagsfile :: Handle -> [FileData] -> IO () -writectagsfile ctagsfile filedata = do - let things = concat $ map getfoundthings filedata - mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things - -getfoundthings :: FileData -> [FoundThing] -getfoundthings (FileData filename things) = things - -dumpthing :: FoundThing -> String -dumpthing (FoundThing modname name loc) = - name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1) - where line = srcLocLine loc - filename = unpackFS $ srcLocFile loc - - --- stuff for dealing with etags output format - -writeetagsfile :: Handle -> [FileData] -> IO () -writeetagsfile etagsfile filedata = do - mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata - -e_dumpfiledata :: FileData -> String -e_dumpfiledata (FileData filename things) = - "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump - where - thingsdump = concat $ map e_dumpthing things - thingslength = length thingsdump +targetsAtOneGo :: Session -> [FileName] -> IO (Maybe [FileData]) +-- 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 -e_dumpthing :: FoundThing -> String -e_dumpthing (FoundThing modname name loc) = - tagline name ++ tagline (moduleNameString modname ++ "." ++ name) - where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n" - line = srcLocLine loc - - - --- like "words", but keeping the whitespace, and so letting us build --- accurate prefixes - -spacedwords :: String -> [String] -spacedwords [] = [] -spacedwords xs = (blanks ++ wordchars):(spacedwords rest2) - where - (blanks,rest) = span Char.isSpace xs - (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest - - --- Find the definitions in a file - -modsummary :: ModuleGraph -> FileName -> Maybe ModSummary -modsummary graph n = - List.find matches graph - where matches ms = n == msHsFilePath ms - -modname :: ModSummary -> ModuleName -modname summary = moduleName $ ms_mod $ summary + 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 + fileTarget :: FileName -> Target fileTarget filename = Target (TargetFile filename Nothing) Nothing +--------------------------------------------------------------- +----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS ----- + graphData :: Session -> ModuleGraph -> IO [FileData] graphData session graph = mapM foundthings graph @@ -194,12 +174,14 @@ graphData session graph = return $ fileData filename modname s fileData :: FileName -> ModuleName -> RenamedSource -> FileData -fileData filename modname (group, imports, lie) = +fileData filename modname (group, _imports, _lie, _doc, _haddock) = -- 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) 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 -> @@ -259,5 +241,67 @@ boundThings modname lbinding = SigPatOut p _ -> patThings p tl DictPat _ _ -> tl conArgs (PrefixCon ps) tl = foldr patThings tl ps - conArgs (RecCon pairs) tl = foldr (\(_id, p) tl -> patThings p tl) tl pairs + conArgs (RecCon pairs) tl = foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl pairs 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 () +writectagsfile ctagsfile filedata = do + let things = concat $ map 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 + +dumpthing :: Bool -> FoundThing -> String +dumpthing showmod (FoundThing modname name loc) = + fullname ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1) + where line = srcLocLine loc + filename = unpackFS $ srcLocFile loc + fullname = if showmod then moduleNameString modname ++ "." ++ name + else name + +-- stuff for dealing with etags output format + +writeetagsfile :: Handle -> [FileData] -> IO () +writeetagsfile etagsfile filedata = do + mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata + +e_dumpfiledata :: FileData -> String +e_dumpfiledata (FileData filename things) = + "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump + where + thingsdump = concat $ map e_dumpthing things + thingslength = length thingsdump + +e_dumpthing :: FoundThing -> String +e_dumpthing (FoundThing modname name loc) = + tagline name ++ tagline (moduleNameString modname ++ "." ++ name) + where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n" + line = srcLocLine loc