Commit abbe21f2 authored by Simon Marlow's avatar Simon Marlow
Browse files

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
parent b21bf3d8
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
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment