From c579872a374fa9e0d59471000b5496963dc8cd8d Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Tue, 6 Nov 2007 13:54:30 +0000 Subject: [PATCH] update to use latest changes to the GHC API (works much quicker now) --- utils/ghctags/GhcTags.hs | 74 +++++++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 34 deletions(-) diff --git a/utils/ghctags/GhcTags.hs b/utils/ghctags/GhcTags.hs index 89cd2b3..cb9108e 100644 --- a/utils/ghctags/GhcTags.hs +++ b/utils/ghctags/GhcTags.hs @@ -1,21 +1,22 @@ -{-# OPTIONS_GHC -XCPP #-} +{-# OPTIONS_GHC -XCPP -XPatternGuards -Wall #-} module Main where -import GHC +import GHC hiding (flags) +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 Util ( handle, handleDyn ) import FastString -import Control.Monad +import Prelude hiding (mapM) +import Control.Monad hiding (mapM) import System.Environment import System.Console.GetOpt import System.Exit @@ -23,6 +24,7 @@ import Data.Char import System.IO import Data.List as List import Data.Maybe +import Data.Traversable (mapM) -- search for definitions of things -- we do this by parsing the source and grabbing top-level definitions @@ -81,13 +83,14 @@ main = do 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 + dflags <- getSessionDynFlags session + (pflags, _) <- parseDynamicFlags dflags{ verbosity=1 } ghcArgs + let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything + GHC.defaultCleanupHandler dflags2 $ do - setSessionDynFlags session flags + setSessionDynFlags session dflags2 targetsAtOneGo session hsfiles (ctags_hdl,etags_hdl) + mapM_ (mapM hClose) [ctags_hdl, etags_hdl] ---------------------------------------------- ---------- ARGUMENT PROCESSING -------------- @@ -146,7 +149,7 @@ 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 ) $ + handle (\_exception -> return Failed ) $ handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn) return Failed) $ load session mode @@ -156,15 +159,12 @@ targetsAtOneGo :: Session -> [FileName] -> (Maybe Handle, Maybe Handle) -> IO () targetsAtOneGo session 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 - 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" + 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 fileTarget :: FileName -> Target fileTarget filename = Target (TargetFile filename Nothing) Nothing @@ -178,12 +178,14 @@ graphData session graph handles = do 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 + in do putStrLn ("loading " ++ filename) + mb_mod <- checkAndLoadModule session ms False + case mb_mod of + _ | isBootSummary ms -> return () + Just mod | Just s <- renamedSource mod -> + writeTagsData handles (fileData filename modname s) + _otherwise -> + exitWith (ExitFailure 1) fileData :: FileName -> ModuleName -> RenamedSource -> FileData fileData filename modname (group, _imports, _lie, _doc, _haddock) = @@ -196,9 +198,10 @@ 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 +209,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,6 +259,7 @@ 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 @@ -263,6 +268,7 @@ boundThings modname lbinding = -- 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 +280,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) = things dumpthing :: Bool -> FoundThing -> String dumpthing showmod (FoundThing modname name loc) = -- 1.7.10.4