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

1 files changed, 152 insertions, 108 deletions

diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs
index fb79a6aaeb..86883f1a05 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