X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghctags%2FGhcTags.hs;h=5237bbc53bba638f9d0343cdef887e943bc55b04;hb=7fb94f753f166563ee3f3b43e7ec5064e82971d3;hp=89cd2b38e56cea621b862adb868ca2bdd807cd56;hpb=cd6fb5688230d9e41f453470d96561b4232b63b2;p=ghc-hetmet.git diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs index 89cd2b3..5237bbc 100644 --- a/utils/ghctags/GhcTags.hs +++ b/utils/ghctags/GhcTags.hs @@ -1,28 +1,43 @@ -{-# OPTIONS_GHC -XCPP #-} +{-# OPTIONS_GHC -XCPP -XPatternGuards -XScopedTypeVariables -Wall #-} module Main where -import GHC +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 -import Outputable -import ErrUtils ( printBagOfErrors ) -import DynFlags(GhcMode, defaultDynFlags) +import Digraph ( flattenSCCs ) +import DriverPhases ( isHaskellSrcFilename ) +import HscTypes ( msHsFilePath ) +import Name ( getOccString ) +--import ErrUtils ( printBagOfErrors ) +import DynFlags ( defaultDynFlags ) import SrcLoc import Bag -import Util ( handle, handleDyn ) +import Exception -- ( ghandle ) import FastString +import MonadUtils ( liftIO ) -import Control.Monad +-- 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 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 @@ -40,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? @@ -49,45 +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) - flags <- getSessionDynFlags session - (pflags, _) <- parseDynamicFlags flags{ verbosity=1 } ghcArgs - let flags = pflags { hscTarget = HscNothing } -- don't generate anything - GHC.defaultCleanupHandler flags $ 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 flags - targetsAtOneGo session hsfiles (ctags_hdl,etags_hdl) + targetsAtOneGo hsfiles (ctags_hdl,etags_hdl) + mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl] ---------------------------------------------- ---------- ARGUMENT PROCESSING -------------- @@ -99,6 +134,8 @@ data Flag | FlagAppend | FlagHelp | FlagTopDir FilePath + | FlagUseCabalConfig FilePath + | FlagFilesFromCabal deriving (Ord, Eq, Show) -- ^Represents options passed to the program @@ -117,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) @@ -134,71 +171,89 @@ 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 - putStrLn $ "Load it all:" - flag <- load session LoadAllTargets - when (failed flag) $ exitWith (ExitFailure 1) - modgraph <- getModuleGraph session + setTargets targets + modgraph <- depanal [] False let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing - graphData session mods handles - - where targetInfo [hs] = "target " ++ hs - targetInfo hss = show (length hss) ++ " targets at one go" + 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 mod <- checkModule session modname False - let fd = maybe (FileData filename []) id $ do - m <- mod - s <- renamedSource m - return $ fileData filename modname s - writeTagsData handles fd - -fileData :: FileName -> ModuleName -> RenamedSource -> FileData -fileData filename modname (group, _imports, _lie, _doc, _haddock) = + 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 s <- renamedSource mod -> + liftIO (writeTagsData handles =<< fileData filename modname s) + _otherwise -> + liftIO $ exitWith (ExitFailure 1) + +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 boundValues mod group = let vals = case hs_valds group of - ValBindsOut nest sigs -> + ValBindsOut nest _sigs -> [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings mod bind ] + _other -> error "boundValues" tys = concat $ map tyBound (hs_tyclds group) where tyBound ltcd = case unLoc ltcd of ForeignType { tcdLName = n } -> [found n] @@ -206,6 +261,7 @@ boundValues mod group = dataNames tycon cons TySynonym { tcdLName = n } -> [found n] ClassDecl { tcdLName = n } -> [found n] + _ -> error "boundValues: tys" fors = concat $ map forBound (hs_fords group) where forBound lford = case unLoc lford of ForeignImport n _ _ -> [found n] @@ -255,14 +311,16 @@ boundThings modname lbinding = TypePat _ -> tl -- XXX need help here SigPatIn p _ -> patThings p tl SigPatOut p _ -> patThings p 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 -- stuff for dealing with ctags output format +writeTagsData :: (Maybe Handle, Maybe Handle) -> FileData -> IO () writeTagsData (mb_ctags_hdl, mb_etags_hdl) fd = do maybe (return ()) (\hdl -> writectagsfile hdl fd) mb_ctags_hdl maybe (return ()) (\hdl -> writeetagsfile hdl fd) mb_etags_hdl @@ -274,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) = @@ -290,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