From 66b57efc054922badaf0b7f8a9010d52bac4ccc2 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Mon, 21 Oct 2013 21:52:33 +0200 Subject: [PATCH 01/10] Add command findsymbol --- src/CommandArgs.hs | 21 ++++++++++++++++++++- src/CommandLoop.hs | 11 +++++++++++ src/FindSymbol.hs | 40 ++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 7 +++++++ src/Types.hs | 1 + 5 files changed, 79 insertions(+), 1 deletion(-) create mode 100644 src/FindSymbol.hs diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index ac96294..3e50a92 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -76,6 +76,11 @@ data HDevTools , line :: Int , col :: Int } + | FindSymbol + { socket :: Maybe FilePath + , ghcOpts :: [String] + , symbol :: String + } deriving (Show, Data, Typeable) dummyAdmin :: HDevTools @@ -121,6 +126,13 @@ dummyType = Type , col = 0 } +dummyFindSymbol :: HDevTools +dummyFindSymbol = FindSymbol + { socket = Nothing + , ghcOpts = [] + , symbol = "" + } + admin :: Annotate Ann admin = record dummyAdmin [ socket := def += typFile += help "socket file to use" @@ -164,8 +176,15 @@ type_ = record dummyType , col := def += typ "COLUMN" += argPos 2 ] += help "Get the type of the expression at the specified line and column" +findSymbol :: Annotate Ann +findSymbol = record dummyFindSymbol + [ socket := def += typFile += help "socket file to use" + , ghcOpts := def += typ "OPTION" += help "ghc options" + , symbol := def += typ "SYMBOL" += argPos 0 + ] += help "Find the modules where the given symbol is defined" + full :: String -> Annotate Ann -full progName = modes_ [admin += auto, check, moduleFile, info, type_] +full progName = modes_ [admin += auto, check, moduleFile, info, type_, findSymbol] += helpArg [name "h", groupname "Help"] += versionArg [groupname "Help"] += program progName diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index bdccb4a..2357dd9 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -27,6 +27,7 @@ import System.Posix.Files (getFileStatus, modificationTime) import Types (ClientDirective(..), Command(..), CommandExtra(..)) import Info (getIdentifierInfo, getType) +import FindSymbol (findSymbol) import Cabal (getPackageGhcOpts) import Stack @@ -229,6 +230,16 @@ runCommand state clientSend (CmdType file (line, col)) = do , show endCol , " " , "\"", t, "\"" ] +runCommand state clientSend (CmdFindSymbol symbol) = do + result <- withWarnings state False $ findSymbol symbol + case result of + [] -> liftIO $ clientSend (ClientExit ExitSuccess) + modules -> liftIO $ mapM_ clientSend + [ ClientStdout (formatModules modules) + , ClientExit ExitSuccess + ] + where + formatModules = intercalate "\n" #if __GLASGOW_HASKELL__ >= 706 logAction :: IORef State -> ClientSend -> GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO () diff --git a/src/FindSymbol.hs b/src/FindSymbol.hs new file mode 100644 index 0000000..0a96668 --- /dev/null +++ b/src/FindSymbol.hs @@ -0,0 +1,40 @@ +module FindSymbol + ( findSymbol + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (foldM) +import Data.List (find) +import qualified GHC +import qualified UniqFM +import qualified Packages as PKG +import qualified Name + +findSymbol :: String -> GHC.Ghc [String] +findSymbol symbol = do + modules <- allExposedModules + modulesWith symbol modules + where + modulesWith sym = foldM (hasSym sym) [] + + hasSym sym modsWithSym modul = do + syms <- allExportedSymbols modul + return $ case find (== sym) syms of + Just _ -> (GHC.moduleNameString modul) : modsWithSym + _ -> modsWithSym + +allExportedSymbols :: GHC.ModuleName -> GHC.Ghc [String] +allExportedSymbols modul = do + maybeInfo <- moduleInfo + case maybeInfo of + Just info -> return $ exports info + _ -> return [] + where + exports = map Name.getOccString . GHC.modInfoExports + moduleInfo = GHC.findModule modul Nothing >>= GHC.getModuleInfo + +allExposedModules :: GHC.Ghc [GHC.ModuleName] +allExposedModules = getExposedModules <$> GHC.getSessionDynFlags + where + getExposedModules = concatMap (\pkg -> if PKG.exposed pkg then PKG.exposedModules pkg else []) + . UniqFM.eltsUFM . PKG.pkgIdMap . GHC.pkgState diff --git a/src/Main.hs b/src/Main.hs index 166306d..4237087 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -35,6 +35,7 @@ fileArg (ModuleFile {}) = Nothing fileArg args@(Check {}) = Just $ file args fileArg args@(Info {}) = Just $ file args fileArg args@(Type {}) = Just $ file args +fileArg (FindSymbol {}) = Nothing pathArg' :: HDevTools -> Maybe String pathArg' (Admin {}) = Nothing @@ -42,6 +43,7 @@ pathArg' (ModuleFile {}) = Nothing pathArg' args@(Check {}) = path args pathArg' args@(Info {}) = path args pathArg' args@(Type {}) = path args +pathArg' (FindSymbol {}) = Nothing pathArg :: HDevTools -> Maybe String pathArg args = case pathArg' args of @@ -67,6 +69,7 @@ main = do ModuleFile {} -> doModuleFile sock args extra Info {} -> doInfo sock args extra Type {} -> doType sock args extra + FindSymbol {} -> doFindSymbol sock args extra doAdmin :: FilePath -> HDevTools -> CommandExtra -> IO () doAdmin sock args _extra @@ -108,3 +111,7 @@ doInfo = doFileCommand "info" $ doType :: FilePath -> HDevTools -> CommandExtra -> IO () doType = doFileCommand "type" $ \args -> CmdType (file args) (line args, col args) + +doFindSymbol :: FilePath -> HDevTools -> CommandExtra -> IO () +doFindSymbol sock args extra = + serverCommand sock (CmdFindSymbol (symbol args) (files args)) extra diff --git a/src/Types.hs b/src/Types.hs index 2470882..0886a15 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -38,4 +38,5 @@ data Command | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) + | CmdFindSymbol String deriving (Read, Show) From a77ef748def8160b3858a63a671a175683b1608b Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Thu, 26 Dec 2013 11:25:30 +0100 Subject: [PATCH 02/10] Error message for 'findsymbol', if no modules could be found --- src/CommandLoop.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 2357dd9..d8894e0 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -233,7 +233,10 @@ runCommand state clientSend (CmdType file (line, col)) = do runCommand state clientSend (CmdFindSymbol symbol) = do result <- withWarnings state False $ findSymbol symbol case result of - [] -> liftIO $ clientSend (ClientExit ExitSuccess) + [] -> liftIO $ mapM_ clientSend + [ ClientStderr $ "Couldn't find modules containing '" ++ symbol ++ "'" + , ClientExit (ExitFailure 1) + ] modules -> liftIO $ mapM_ clientSend [ ClientStdout (formatModules modules) , ClientExit ExitSuccess From 0b84a71cd329798c6f71e860b8bac59d0716c12a Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Thu, 26 Dec 2013 12:00:43 +0100 Subject: [PATCH 03/10] Handle GHC exceptions --- src/FindSymbol.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/FindSymbol.hs b/src/FindSymbol.hs index 0a96668..a12e4ea 100644 --- a/src/FindSymbol.hs +++ b/src/FindSymbol.hs @@ -1,14 +1,17 @@ + module FindSymbol ( findSymbol ) where import Control.Applicative ((<$>)) import Control.Monad (foldM) +import Control.Exception import Data.List (find) import qualified GHC import qualified UniqFM import qualified Packages as PKG import qualified Name +import Exception (ghandle) findSymbol :: String -> GHC.Ghc [String] findSymbol symbol = do @@ -25,11 +28,15 @@ findSymbol symbol = do allExportedSymbols :: GHC.ModuleName -> GHC.Ghc [String] allExportedSymbols modul = do - maybeInfo <- moduleInfo - case maybeInfo of - Just info -> return $ exports info - _ -> return [] + ghandle handleException $ do + maybeInfo <- moduleInfo + return $ case maybeInfo of + Just info -> exports info + _ -> [] where + handleException :: SomeException -> GHC.Ghc [String] + handleException _ = return [] + exports = map Name.getOccString . GHC.modInfoExports moduleInfo = GHC.findModule modul Nothing >>= GHC.getModuleInfo From 8709857aa6c25004fde1662b8e04e61bfa25b72b Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Wed, 1 Jan 2014 18:23:22 +0100 Subject: [PATCH 04/10] findsymbol with sourcefile --- src/CommandArgs.hs | 3 +++ src/CommandLoop.hs | 10 +++++++++- src/FindSymbol.hs | 45 ++++++++++++++++++++++++++------------------- src/Types.hs | 2 +- 4 files changed, 39 insertions(+), 21 deletions(-) diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index 3e50a92..7595dea 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -80,6 +80,7 @@ data HDevTools { socket :: Maybe FilePath , ghcOpts :: [String] , symbol :: String + , file :: String } deriving (Show, Data, Typeable) @@ -131,6 +132,7 @@ dummyFindSymbol = FindSymbol { socket = Nothing , ghcOpts = [] , symbol = "" + , file = "" } admin :: Annotate Ann @@ -181,6 +183,7 @@ findSymbol = record dummyFindSymbol [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options" , symbol := def += typ "SYMBOL" += argPos 0 + , file := def += typFile += argPos 1 ] += help "Find the modules where the given symbol is defined" full :: String -> Annotate Ann diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index d8894e0..7fc1b9e 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -230,7 +230,13 @@ runCommand state clientSend (CmdType file (line, col)) = do , show endCol , " " , "\"", t, "\"" ] -runCommand state clientSend (CmdFindSymbol symbol) = do +runCommand state clientSend (CmdFindSymbol symbol file) = do + let noPhase = Nothing + target <- GHC.guessTarget file noPhase + GHC.setTargets [target] + let handler err = GHC.printException err >> return GHC.Failed + _ <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) + result <- withWarnings state False $ findSymbol symbol case result of [] -> liftIO $ mapM_ clientSend @@ -244,6 +250,8 @@ runCommand state clientSend (CmdFindSymbol symbol) = do where formatModules = intercalate "\n" + + #if __GLASGOW_HASKELL__ >= 706 logAction :: IORef State -> ClientSend -> GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO () logAction state clientSend dflags severity srcspan style msg = diff --git a/src/FindSymbol.hs b/src/FindSymbol.hs index a12e4ea..fd8e103 100644 --- a/src/FindSymbol.hs +++ b/src/FindSymbol.hs @@ -1,3 +1,4 @@ +{-# Language ScopedTypeVariables #-} module FindSymbol ( findSymbol @@ -7,6 +8,7 @@ import Control.Applicative ((<$>)) import Control.Monad (foldM) import Control.Exception import Data.List (find) +import Data.Maybe (catMaybes) import qualified GHC import qualified UniqFM import qualified Packages as PKG @@ -15,33 +17,38 @@ import Exception (ghandle) findSymbol :: String -> GHC.Ghc [String] findSymbol symbol = do - modules <- allExposedModules - modulesWith symbol modules + graphModules <- modulesWith symbol =<< allModulesFromGraph + expModules <- modulesWith symbol =<< allExposedModules + return $ graphModules ++ expModules where modulesWith sym = foldM (hasSym sym) [] hasSym sym modsWithSym modul = do syms <- allExportedSymbols modul return $ case find (== sym) syms of - Just _ -> (GHC.moduleNameString modul) : modsWithSym + Just _ -> (GHC.moduleNameString . GHC.moduleName $ modul) : modsWithSym _ -> modsWithSym -allExportedSymbols :: GHC.ModuleName -> GHC.Ghc [String] -allExportedSymbols modul = do - ghandle handleException $ do - maybeInfo <- moduleInfo - return $ case maybeInfo of - Just info -> exports info - _ -> [] - where - handleException :: SomeException -> GHC.Ghc [String] - handleException _ = return [] +allExportedSymbols :: GHC.Module -> GHC.Ghc [String] +allExportedSymbols module_ = + ghandle (\(_ :: SomeException) -> return []) + (do info <- GHC.getModuleInfo module_ + return $ maybe [] (map Name.getOccString . GHC.modInfoExports) info) - exports = map Name.getOccString . GHC.modInfoExports - moduleInfo = GHC.findModule modul Nothing >>= GHC.getModuleInfo +allModulesFromGraph :: GHC.Ghc [GHC.Module] +allModulesFromGraph = do + moduleGraph <- GHC.getModuleGraph + return $ map GHC.ms_mod moduleGraph -allExposedModules :: GHC.Ghc [GHC.ModuleName] -allExposedModules = getExposedModules <$> GHC.getSessionDynFlags +allExposedModules :: GHC.Ghc [GHC.Module] +allExposedModules = do + modNames <- exposedModuleNames <$> GHC.getSessionDynFlags + catMaybes <$> mapM findModule modNames where - getExposedModules = concatMap (\pkg -> if PKG.exposed pkg then PKG.exposedModules pkg else []) - . UniqFM.eltsUFM . PKG.pkgIdMap . GHC.pkgState + exposedModuleNames = concatMap (\pkg -> if PKG.exposed pkg then PKG.exposedModules pkg else []) + . UniqFM.eltsUFM . PKG.pkgIdMap . GHC.pkgState + +findModule :: GHC.ModuleName -> GHC.Ghc (Maybe GHC.Module) +findModule moduleName = + ghandle (\(_ :: SomeException) -> return Nothing) + (Just <$> GHC.findModule moduleName Nothing) diff --git a/src/Types.hs b/src/Types.hs index 0886a15..ce7b6dd 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -38,5 +38,5 @@ data Command | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) - | CmdFindSymbol String + | CmdFindSymbol String String deriving (Read, Show) From d283c0d7133184bf817c8ffe8887ea8ab941f786 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Fri, 3 Jan 2014 22:20:22 +0100 Subject: [PATCH 05/10] Allow multiple source files for 'findsymbol' --- src/CommandArgs.hs | 6 +++--- src/CommandLoop.hs | 6 +++--- src/Types.hs | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index 7595dea..21ff736 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -80,7 +80,7 @@ data HDevTools { socket :: Maybe FilePath , ghcOpts :: [String] , symbol :: String - , file :: String + , files :: [String] } deriving (Show, Data, Typeable) @@ -132,7 +132,7 @@ dummyFindSymbol = FindSymbol { socket = Nothing , ghcOpts = [] , symbol = "" - , file = "" + , files = [] } admin :: Annotate Ann @@ -183,7 +183,7 @@ findSymbol = record dummyFindSymbol [ socket := def += typFile += help "socket file to use" , ghcOpts := def += typ "OPTION" += help "ghc options" , symbol := def += typ "SYMBOL" += argPos 0 - , file := def += typFile += argPos 1 + , files := def += typFile += args ] += help "Find the modules where the given symbol is defined" full :: String -> Annotate Ann diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 7fc1b9e..bac32df 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -230,10 +230,10 @@ runCommand state clientSend (CmdType file (line, col)) = do , show endCol , " " , "\"", t, "\"" ] -runCommand state clientSend (CmdFindSymbol symbol file) = do +runCommand state clientSend (CmdFindSymbol symbol files) = do let noPhase = Nothing - target <- GHC.guessTarget file noPhase - GHC.setTargets [target] + targets <- mapM (flip GHC.guessTarget noPhase) files + GHC.setTargets targets let handler err = GHC.printException err >> return GHC.Failed _ <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) diff --git a/src/Types.hs b/src/Types.hs index ce7b6dd..4daa50f 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -38,5 +38,5 @@ data Command | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) - | CmdFindSymbol String String + | CmdFindSymbol String [String] deriving (Read, Show) From 6e7bb99ed914ecbe701aab1ba58191aa270fbefe Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Sat, 4 Jan 2014 00:50:59 +0100 Subject: [PATCH 06/10] Don't output any GHC warings/errors for the 'findsymbol' command --- src/CommandLoop.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index bac32df..a61c6ee 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -231,12 +231,21 @@ runCommand state clientSend (CmdType file (line, col)) = do , "\"", t, "\"" ] runCommand state clientSend (CmdFindSymbol symbol files) = do + -- for the findsymbol command GHC shouldn't output any warnings + -- or errors to stdout for the loaded source files, we're only + -- interested in the module graph of the loaded targets + dynFlags <- GHC.getSessionDynFlags + _ <- GHC.setSessionDynFlags dynFlags { GHC.log_action = \_ _ _ _ _ -> return () } + let noPhase = Nothing targets <- mapM (flip GHC.guessTarget noPhase) files GHC.setTargets targets let handler err = GHC.printException err >> return GHC.Failed _ <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) + -- reset the old log_action + _ <- GHC.setSessionDynFlags dynFlags + result <- withWarnings state False $ findSymbol symbol case result of [] -> liftIO $ mapM_ clientSend From d0b794d964d5c51b3f9ccad59dd559ba7269dd9e Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Sat, 4 Jan 2014 00:51:23 +0100 Subject: [PATCH 07/10] Return each module only once --- src/FindSymbol.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/FindSymbol.hs b/src/FindSymbol.hs index fd8e103..794d7c4 100644 --- a/src/FindSymbol.hs +++ b/src/FindSymbol.hs @@ -7,7 +7,7 @@ module FindSymbol import Control.Applicative ((<$>)) import Control.Monad (foldM) import Control.Exception -import Data.List (find) +import Data.List (find, nub) import Data.Maybe (catMaybes) import qualified GHC import qualified UniqFM @@ -19,7 +19,7 @@ findSymbol :: String -> GHC.Ghc [String] findSymbol symbol = do graphModules <- modulesWith symbol =<< allModulesFromGraph expModules <- modulesWith symbol =<< allExposedModules - return $ graphModules ++ expModules + return . nub $ graphModules ++ expModules where modulesWith sym = foldM (hasSym sym) [] From 24e719cc60d8a2cb2049d9dd0f49bdd50e4be770 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Sat, 4 Jan 2014 11:11:25 +0100 Subject: [PATCH 08/10] Load each file/target separately for the 'findsymbol' command To be able to continue loading of files and reading their module graph if an error occured during the loading of a file, because if all files are loaded at once, then GHC stops the loading if an error occured. --- src/CommandLoop.hs | 17 +------- src/FindSymbol.hs | 97 +++++++++++++++++++++++++++++----------------- 2 files changed, 62 insertions(+), 52 deletions(-) diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index a61c6ee..80665b9 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -231,22 +231,7 @@ runCommand state clientSend (CmdType file (line, col)) = do , "\"", t, "\"" ] runCommand state clientSend (CmdFindSymbol symbol files) = do - -- for the findsymbol command GHC shouldn't output any warnings - -- or errors to stdout for the loaded source files, we're only - -- interested in the module graph of the loaded targets - dynFlags <- GHC.getSessionDynFlags - _ <- GHC.setSessionDynFlags dynFlags { GHC.log_action = \_ _ _ _ _ -> return () } - - let noPhase = Nothing - targets <- mapM (flip GHC.guessTarget noPhase) files - GHC.setTargets targets - let handler err = GHC.printException err >> return GHC.Failed - _ <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) - - -- reset the old log_action - _ <- GHC.setSessionDynFlags dynFlags - - result <- withWarnings state False $ findSymbol symbol + result <- withWarnings state False $ findSymbol symbol files case result of [] -> liftIO $ mapM_ clientSend [ ClientStderr $ "Couldn't find modules containing '" ++ symbol ++ "'" diff --git a/src/FindSymbol.hs b/src/FindSymbol.hs index 794d7c4..1c40b6b 100644 --- a/src/FindSymbol.hs +++ b/src/FindSymbol.hs @@ -5,50 +5,75 @@ module FindSymbol ) where import Control.Applicative ((<$>)) -import Control.Monad (foldM) +import Control.Monad (filterM) import Control.Exception import Data.List (find, nub) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, isJust) import qualified GHC import qualified UniqFM import qualified Packages as PKG import qualified Name import Exception (ghandle) -findSymbol :: String -> GHC.Ghc [String] -findSymbol symbol = do - graphModules <- modulesWith symbol =<< allModulesFromGraph - expModules <- modulesWith symbol =<< allExposedModules - return . nub $ graphModules ++ expModules +type SymbolName = String +type ModuleName = String + +findSymbol :: SymbolName -> [FilePath] -> GHC.Ghc [ModuleName] +findSymbol symbol files = do + -- for the findsymbol command GHC shouldn't output any warnings + -- or errors to stdout for the loaded source files, we're only + -- interested in the module graph of the loaded targets + dynFlags <- GHC.getSessionDynFlags + _ <- GHC.setSessionDynFlags dynFlags { GHC.log_action = \_ _ _ _ _ -> return () } + + fileMods <- concat <$> mapM (findSymbolInFile symbol) files + + -- reset the old log_action + _ <- GHC.setSessionDynFlags dynFlags + + pkgsMods <- findSymbolInPackages symbol + return . nub . map (GHC.moduleNameString . GHC.moduleName) $ fileMods ++ pkgsMods + + +findSymbolInFile :: SymbolName -> FilePath -> GHC.Ghc [GHC.Module] +findSymbolInFile symbol file = do + loadFile + filterM (containsSymbol symbol) =<< fileModules where - modulesWith sym = foldM (hasSym sym) [] - - hasSym sym modsWithSym modul = do - syms <- allExportedSymbols modul - return $ case find (== sym) syms of - Just _ -> (GHC.moduleNameString . GHC.moduleName $ modul) : modsWithSym - _ -> modsWithSym - -allExportedSymbols :: GHC.Module -> GHC.Ghc [String] -allExportedSymbols module_ = - ghandle (\(_ :: SomeException) -> return []) - (do info <- GHC.getModuleInfo module_ - return $ maybe [] (map Name.getOccString . GHC.modInfoExports) info) - -allModulesFromGraph :: GHC.Ghc [GHC.Module] -allModulesFromGraph = do - moduleGraph <- GHC.getModuleGraph - return $ map GHC.ms_mod moduleGraph - -allExposedModules :: GHC.Ghc [GHC.Module] -allExposedModules = do - modNames <- exposedModuleNames <$> GHC.getSessionDynFlags - catMaybes <$> mapM findModule modNames + loadFile = do + let noPhase = Nothing + target <- GHC.guessTarget file noPhase + GHC.setTargets [target] + let handler err = GHC.printException err >> return GHC.Failed + _ <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets) + return () + + fileModules = map GHC.ms_mod <$> GHC.getModuleGraph + + +findSymbolInPackages :: SymbolName -> GHC.Ghc [GHC.Module] +findSymbolInPackages symbol = + filterM (containsSymbol symbol) =<< allExposedModules where - exposedModuleNames = concatMap (\pkg -> if PKG.exposed pkg then PKG.exposedModules pkg else []) - . UniqFM.eltsUFM . PKG.pkgIdMap . GHC.pkgState + allExposedModules :: GHC.Ghc [GHC.Module] + allExposedModules = do + modNames <- exposedModuleNames <$> GHC.getSessionDynFlags + catMaybes <$> mapM findModule modNames + where + exposedModuleNames = concatMap (\pkg -> if PKG.exposed pkg then PKG.exposedModules pkg else []) + . UniqFM.eltsUFM . PKG.pkgIdMap . GHC.pkgState -findModule :: GHC.ModuleName -> GHC.Ghc (Maybe GHC.Module) -findModule moduleName = - ghandle (\(_ :: SomeException) -> return Nothing) - (Just <$> GHC.findModule moduleName Nothing) + findModule :: GHC.ModuleName -> GHC.Ghc (Maybe GHC.Module) + findModule moduleName = + ghandle (\(_ :: SomeException) -> return Nothing) + (Just <$> GHC.findModule moduleName Nothing) + + +containsSymbol :: SymbolName -> GHC.Module -> GHC.Ghc Bool +containsSymbol symbol module_ = + isJust . find (== symbol) <$> allExportedSymbols + where + allExportedSymbols = + ghandle (\(_ :: SomeException) -> return []) + (do info <- GHC.getModuleInfo module_ + return $ maybe [] (map Name.getOccString . GHC.modInfoExports) info) From 202108381470d73ae4b6cfd5a424ec2fe81def95 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Thu, 6 Aug 2015 19:15:19 +0200 Subject: [PATCH 09/10] Change help message of findsymbol command --- src/CommandArgs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index 21ff736..2f79080 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -184,7 +184,7 @@ findSymbol = record dummyFindSymbol , ghcOpts := def += typ "OPTION" += help "ghc options" , symbol := def += typ "SYMBOL" += argPos 0 , files := def += typFile += args - ] += help "Find the modules where the given symbol is defined" + ] += help "List the modules where the given symbol could be found" full :: String -> Annotate Ann full progName = modes_ [admin += auto, check, moduleFile, info, type_, findSymbol] From 4c7bcfd88e548716718cedb2a1392763ddc75504 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Fri, 7 Aug 2015 10:37:16 +0200 Subject: [PATCH 10/10] findsymbol: add support for ghc 7.10 --- hdevtools.cabal | 4 +++- src/CommandLoop.hs | 4 ++-- src/FindSymbol.hs | 32 ++++++++++++++++++++++++++------ 3 files changed, 31 insertions(+), 9 deletions(-) diff --git a/hdevtools.cabal b/hdevtools.cabal index f3de2c3..54ae662 100644 --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -81,5 +81,7 @@ executable hdevtools cpp-options: -DENABLE_CABAL if impl(ghc >= 7.9) - build-depends: Cabal >= 1.22 + build-depends: Cabal >= 1.22, + bin-package-db + cpp-options: -DENABLE_CABAL diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 80665b9..13d2b70 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -9,7 +9,7 @@ module CommandLoop import Control.Monad (when) import Data.IORef -import Data.List (find) +import Data.List (find, intercalate) #if __GLASGOW_HASKELL__ < 709 import Data.Traversable (traverse) #endif @@ -244,7 +244,7 @@ runCommand state clientSend (CmdFindSymbol symbol files) = do where formatModules = intercalate "\n" - + #if __GLASGOW_HASKELL__ >= 706 logAction :: IORef State -> ClientSend -> GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> Outputable.PprStyle -> ErrUtils.MsgDoc -> IO () diff --git a/src/FindSymbol.hs b/src/FindSymbol.hs index 1c40b6b..26dcde3 100644 --- a/src/FindSymbol.hs +++ b/src/FindSymbol.hs @@ -1,16 +1,22 @@ -{-# Language ScopedTypeVariables #-} +{-# Language ScopedTypeVariables, CPP #-} module FindSymbol ( findSymbol ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +import qualified UniqFM +#else +import GHC.PackageDb (exposedName) +import GhcMonad (liftIO) +#endif + import Control.Monad (filterM) import Control.Exception import Data.List (find, nub) import Data.Maybe (catMaybes, isJust) -import qualified GHC -import qualified UniqFM +import qualified GHC import qualified Packages as PKG import qualified Name import Exception (ghandle) @@ -57,11 +63,25 @@ findSymbolInPackages symbol = where allExposedModules :: GHC.Ghc [GHC.Module] allExposedModules = do - modNames <- exposedModuleNames <$> GHC.getSessionDynFlags + modNames <- exposedModuleNames catMaybes <$> mapM findModule modNames where - exposedModuleNames = concatMap (\pkg -> if PKG.exposed pkg then PKG.exposedModules pkg else []) - . UniqFM.eltsUFM . PKG.pkgIdMap . GHC.pkgState + exposedModuleNames :: GHC.Ghc [GHC.ModuleName] +#if __GLASGOW_HASKELL__ < 710 + exposedModuleNames = + concatMap exposedModules + . UniqFM.eltsUFM + . PKG.pkgIdMap + . GHC.pkgState + <$> GHC.getSessionDynFlags +#else + exposedModuleNames = do + dynFlags <- GHC.getSessionDynFlags + pkgConfigs <- liftIO $ PKG.readPackageConfigs dynFlags + return $ map exposedName (concatMap exposedModules pkgConfigs) +#endif + + exposedModules pkg = if PKG.exposed pkg then PKG.exposedModules pkg else [] findModule :: GHC.ModuleName -> GHC.Ghc (Maybe GHC.Module) findModule moduleName =