X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghctags%2FGhcTags.hs;h=5237bbc53bba638f9d0343cdef887e943bc55b04;hb=7fb94f753f166563ee3f3b43e7ec5064e82971d3;hp=cb9108eddd4685115ebb777cda669513531dce51;hpb=c579872a374fa9e0d59471000b5496963dc8cd8d;p=ghc-hetmet.git diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs index cb9108e..5237bbc 100644 --- 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 +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 ErrUtils ( printBagOfErrors ) import DynFlags ( defaultDynFlags ) import SrcLoc import Bag -import Util ( handle, handleDyn ) +import Exception -- ( ghandle ) 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 Data.List as List +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 @@ -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 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? @@ -51,46 +64,65 @@ 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 (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 -------------- @@ -102,6 +134,8 @@ data Flag | FlagAppend | FlagHelp | FlagTopDir FilePath + | FlagUseCabalConfig FilePath + | FlagFilesFromCabal 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 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) @@ -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)") + , 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] -> (Maybe Handle, Maybe Handle) -> IO () +targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc () -- load a list of targets -targetsAtOneGo session hsfiles handles = do +targetsAtOneGo hsfiles handles = do 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 (TargetFile filename Nothing) Nothing +fileTarget filename = Target (TargetFile filename Nothing) True Nothing --------------------------------------------------------------- ----- 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 - 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 () - Just mod | Just s <- renamedSource mod -> - writeTagsData handles (fileData filename modname s) + _ | Just s <- renamedSource mod -> + liftIO (writeTagsData handles =<< fileData filename modname s) _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 - 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 @@ -262,7 +314,7 @@ boundThings modname lbinding = _ -> 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 @@ -280,7 +332,7 @@ writectagsfile ctagsfile filedata = do 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) = @@ -296,14 +348,21 @@ 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