Use cabal information to get GHC's flags to `ghctags'.

[ghc-hetmet.git] / utils / ghctags / GhcTags.hs

diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs
index cb9108e..5237bbc 100644 (file)
--- a/utils/ghctags/GhcTags.hs
+++ b/utils/ghctags/GhcTags.hs
@@ -1,30 +1,43 @@
-{-# OPTIONS_GHC -XCPP -XPatternGuards -Wall #-}
+{-# OPTIONS_GHC -XCPP -XPatternGuards -XScopedTypeVariables -Wall #-}

 module Main where
 
 module Main where
 

+import Prelude hiding ( mod, id, mapM )

 import GHC hiding (flags)
 import GHC hiding (flags)

+--import Packages

 import HscTypes         ( isBootSummary )
 import BasicTypes
 import Digraph          ( flattenSCCs )
 import DriverPhases     ( isHaskellSrcFilename )
 import HscTypes         ( msHsFilePath )
 import Name             ( getOccString )
 import HscTypes         ( isBootSummary )
 import BasicTypes
 import Digraph          ( flattenSCCs )
 import DriverPhases     ( isHaskellSrcFilename )
 import HscTypes         ( msHsFilePath )
 import Name             ( getOccString )

-import ErrUtils         ( printBagOfErrors )
+--import ErrUtils         ( printBagOfErrors )

 import DynFlags         ( defaultDynFlags )
 import SrcLoc
 import Bag
 import DynFlags         ( defaultDynFlags )
 import SrcLoc
 import Bag

-import Util             ( handle, handleDyn )
+import Exception --        ( ghandle )

 import FastString
 import FastString

+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 Prelude hiding (mapM)

 import Control.Monad hiding (mapM)
 import System.Environment
 import System.Console.GetOpt
 import System.Exit
 import Data.Char
 import System.IO
 import Control.Monad hiding (mapM)
 import System.Environment
 import System.Console.GetOpt
 import System.Exit
 import Data.Char
 import System.IO

-import Data.List as List
+import Data.List as List hiding ( group )

 import Data.Maybe
 import Data.Traversable (mapM)
 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
 
 -- search for definitions of things 
 -- we do this by parsing the source and grabbing top-level definitions

@@ -42,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 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?
 
 
 --- invariant (not checked): every found thing has a source location in that file?
 
 

@@ -51,46 +64,65 @@ data FileData = FileData FileName [FoundThing]
 
 main :: IO ()
 main = do
 
 main :: IO ()
 main = do

-        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 ()
-
-        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 $ do
-          session <- newSession (Just ghc_topdir)
-          dflags <- getSessionDynFlags session
-          (pflags, _) <- parseDynamicFlags dflags{ verbosity=1 } ghcArgs
-          let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
-          GHC.defaultCleanupHandler dflags2 $ do
+  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

   
   

-          setSessionDynFlags session dflags2
-          targetsAtOneGo session hsfiles (ctags_hdl,etags_hdl)
-          mapM_ (mapM hClose) [ctags_hdl, etags_hdl]
+        targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
+        mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]

 
 ----------------------------------------------
 ----------  ARGUMENT PROCESSING --------------
 
 ----------------------------------------------
 ----------  ARGUMENT PROCESSING --------------

@@ -102,6 +134,8 @@ data Flag
    | FlagAppend
    | FlagHelp
    | FlagTopDir FilePath
    | FlagAppend
    | FlagHelp
    | FlagTopDir FilePath

+   | FlagUseCabalConfig FilePath
+   | FlagFilesFromCabal

   deriving (Ord, Eq, Show)
   -- ^Represents options passed to the program
 
   deriving (Ord, Eq, Show)
   -- ^Represents options passed to the program
 

@@ -120,7 +154,7 @@ getMode fs = go (concatMap modeLike fs)
 
 splitArgs :: [String] -> ([String], [String], Bool)
 -- ^Pull out arguments between -- for GHC
 
 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)
     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)

@@ -137,62 +171,80 @@ options = [ Option "" ["topdir"]
            (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
          , Option "a" ["append"]
            (NoArg FlagAppend) ("append to existing CTAGS and/or ETAGS file(s)")
            (NoArg FlagBoth) ("generate both CTAGS and ETAGS")
          , Option "a" ["append"]
            (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"
          ]
 
          , 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)
 
 
 ----------------------------------------------------------------
 --- 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
 -- 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] -> (Maybe Handle, Maybe Handle) -> IO ()
+targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc ()

 -- load a list of targets
 -- load a list of targets

-targetsAtOneGo session hsfiles handles = do
+targetsAtOneGo hsfiles handles = do

   targets <- mapM (\f -> guessTarget f Nothing) hsfiles
   targets <- mapM (\f -> guessTarget f Nothing) hsfiles

-  setTargets session targets
-  mb_modgraph <- depanal session [] False
-  case mb_modgraph of
-    Nothing -> exitWith (ExitFailure 1)
-    Just modgraph -> do
-        let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
-        graphData session mods handles
+  setTargets targets
+  modgraph <- depanal [] False
+  let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
+  graphData mods handles

 
 fileTarget :: FileName -> Target
 
 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 -----
 
 
 ---------------------------------------------------------------
 ----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
 

-graphData :: Session -> ModuleGraph -> (Maybe Handle, Maybe Handle) -> IO ()
-graphData session graph handles = do
+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
     mapM_ foundthings graph
     where foundthings ms =
               let filename = msHsFilePath ms
                   modname = moduleName $ ms_mod ms

-              in  do putStrLn ("loading " ++ filename)
-                     mb_mod <- checkAndLoadModule session ms False
-                     case mb_mod of
+              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 ()
                        _ | isBootSummary ms -> return ()

-                       Just mod | Just s <- renamedSource mod ->
-                         writeTagsData handles (fileData filename modname s)
+                       _ | Just s <- renamedSource mod ->
+                         liftIO (writeTagsData handles =<< fileData filename modname s)

                        _otherwise ->
                        _otherwise ->

-                         exitWith (ExitFailure 1)
+                         liftIO $ exitWith (ExitFailure 1)

 
 

-fileData :: FileName -> ModuleName -> RenamedSource -> FileData
-fileData filename modname (group, _imports, _lie, _doc, _haddock) =
+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
     -- 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 :: ModuleName -> HsGroup Name -> [FoundThing]    
 -- ^Finds all the top-level definitions in a module

@@ -262,7 +314,7 @@ boundThings modname lbinding =
                _ -> error "boundThings"
         conArgs (PrefixCon ps) tl = foldr patThings tl ps
         conArgs (RecCon (HsRecFields { rec_flds = flds })) tl 
                _ -> error "boundThings"
         conArgs (PrefixCon ps) tl = foldr patThings tl ps
         conArgs (RecCon (HsRecFields { rec_flds = flds })) tl 

-             = foldr (\f tl -> patThings (hsRecFieldArg f) tl) tl flds
+             = foldr (\f tl' -> patThings (hsRecFieldArg f) tl') tl flds

         conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
 
 
         conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
 
 

@@ -280,7 +332,7 @@ writectagsfile ctagsfile filedata = do
        mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing True  x) things
 
 getfoundthings :: FileData -> [FoundThing]
        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) =
 
 dumpthing :: Bool -> FoundThing -> String
 dumpthing showmod (FoundThing modname name loc) =

@@ -296,14 +348,21 @@ writeetagsfile :: Handle -> FileData -> IO ()
 writeetagsfile etagsfile = hPutStr etagsfile . e_dumpfiledata
 
 e_dumpfiledata :: FileData -> String
 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 
        "\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
 
                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)
     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
           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