From 66ec77f692a2680b16a2187c90b9951f65934226 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Mon, 21 Oct 2013 21:51:27 +0200 Subject: [PATCH 01/15] gitignore: add cabal sandbox dir/file --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 178135c..373259b 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,3 @@ /dist/ +.cabal-sandbox +cabal.sandbox.config From 75e7da66d180c86d0b6edfe2de2980ed21e4a919 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Mon, 21 Oct 2013 21:52:33 +0200 Subject: [PATCH 02/15] Add command findsymbol --- src/CommandArgs.hs | 21 ++++++++++++++++++++- src/CommandLoop.hs | 13 ++++++++++++- src/FindSymbol.hs | 40 ++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 5 +++++ src/Types.hs | 1 + 5 files changed, 78 insertions(+), 2 deletions(-) create mode 100644 src/FindSymbol.hs diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index 2149b29..e99a916 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -62,6 +62,11 @@ data HDevTools , line :: Int , col :: Int } + | FindSymbol + { socket :: Maybe FilePath + , ghcOpts :: [String] + , symbol :: String + } deriving (Show, Data, Typeable) dummyAdmin :: HDevTools @@ -104,6 +109,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" @@ -144,8 +156,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 1a62ca3..b7db2e1 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -6,7 +6,7 @@ module CommandLoop import Control.Monad (when) import Data.IORef -import Data.List (find) +import Data.List (find, intercalate) import MonadUtils (MonadIO, liftIO) import System.Exit (ExitCode(ExitFailure, ExitSuccess)) import qualified ErrUtils @@ -17,6 +17,7 @@ import qualified Outputable import Types (ClientDirective(..), Command(..)) import Info (getIdentifierInfo, getType) +import FindSymbol (findSymbol) type CommandObj = (Command, [String]) @@ -168,6 +169,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 517f224..358960c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -26,6 +26,7 @@ main = do ModuleFile {} -> doModuleFile sock args Info {} -> doInfo sock args Type {} -> doType sock args + FindSymbol {} -> doFindSymbol sock args doAdmin :: FilePath -> HDevTools -> IO () doAdmin sock args @@ -64,3 +65,7 @@ doInfo = doFileCommand "info" $ doType :: FilePath -> HDevTools -> IO () doType = doFileCommand "type" $ \args -> CmdType (file args) (line args, col args) + +doFindSymbol :: FilePath -> HDevTools -> IO () +doFindSymbol sock args = + serverCommand sock (CmdFindSymbol (symbol args)) (ghcOpts args) diff --git a/src/Types.hs b/src/Types.hs index 9b50707..46f710e 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -24,4 +24,5 @@ data Command | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) + | CmdFindSymbol String deriving (Read, Show) From 68334f7220810f4ac522fef2fc93141cdaf94099 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Thu, 26 Dec 2013 11:25:30 +0100 Subject: [PATCH 03/15] 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 b7db2e1..5e5e3d9 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -172,7 +172,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 fce6a205f219c1394a7b904b29352f1ebfc97f29 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Thu, 26 Dec 2013 12:00:43 +0100 Subject: [PATCH 04/15] 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 a5de88c46cb52b36866f62f6e4c5f8fbba9c04ce Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Wed, 1 Jan 2014 18:23:22 +0100 Subject: [PATCH 05/15] findsymbol with sourcefile --- src/CommandArgs.hs | 3 +++ src/CommandLoop.hs | 10 +++++++++- src/FindSymbol.hs | 45 ++++++++++++++++++++++++++------------------- src/Main.hs | 2 +- src/Types.hs | 2 +- 5 files changed, 40 insertions(+), 22 deletions(-) diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index e99a916..3be35da 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -66,6 +66,7 @@ data HDevTools { socket :: Maybe FilePath , ghcOpts :: [String] , symbol :: String + , file :: String } deriving (Show, Data, Typeable) @@ -114,6 +115,7 @@ dummyFindSymbol = FindSymbol { socket = Nothing , ghcOpts = [] , symbol = "" + , file = "" } admin :: Annotate Ann @@ -161,6 +163,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 5e5e3d9..0dda647 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -169,7 +169,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 @@ -183,6 +189,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/Main.hs b/src/Main.hs index 358960c..ed0d1d0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -68,4 +68,4 @@ doType = doFileCommand "type" $ doFindSymbol :: FilePath -> HDevTools -> IO () doFindSymbol sock args = - serverCommand sock (CmdFindSymbol (symbol args)) (ghcOpts args) + serverCommand sock (CmdFindSymbol (symbol args) (file args)) (ghcOpts args) diff --git a/src/Types.hs b/src/Types.hs index 46f710e..df8ecf3 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -24,5 +24,5 @@ data Command | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) - | CmdFindSymbol String + | CmdFindSymbol String String deriving (Read, Show) From e1c5e6c84d742bef55af9fab15ce628beff21551 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Fri, 3 Jan 2014 22:20:22 +0100 Subject: [PATCH 06/15] Allow multiple source files for 'findsymbol' --- src/CommandArgs.hs | 6 +++--- src/CommandLoop.hs | 6 +++--- src/Main.hs | 2 +- src/Types.hs | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs index 3be35da..5d045b4 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -66,7 +66,7 @@ data HDevTools { socket :: Maybe FilePath , ghcOpts :: [String] , symbol :: String - , file :: String + , files :: [String] } deriving (Show, Data, Typeable) @@ -115,7 +115,7 @@ dummyFindSymbol = FindSymbol { socket = Nothing , ghcOpts = [] , symbol = "" - , file = "" + , files = [] } admin :: Annotate Ann @@ -163,7 +163,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 0dda647..0256b48 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -169,10 +169,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/Main.hs b/src/Main.hs index ed0d1d0..d650328 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -68,4 +68,4 @@ doType = doFileCommand "type" $ doFindSymbol :: FilePath -> HDevTools -> IO () doFindSymbol sock args = - serverCommand sock (CmdFindSymbol (symbol args) (file args)) (ghcOpts args) + serverCommand sock (CmdFindSymbol (symbol args) (files args)) (ghcOpts args) diff --git a/src/Types.hs b/src/Types.hs index df8ecf3..3511a39 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -24,5 +24,5 @@ data Command | CmdModuleFile String | CmdInfo FilePath String | CmdType FilePath (Int, Int) - | CmdFindSymbol String String + | CmdFindSymbol String [String] deriving (Read, Show) From c74ca08987c8872d62d9d68447a81e8828d88919 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Sat, 4 Jan 2014 00:50:59 +0100 Subject: [PATCH 07/15] 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 0256b48..d60e051 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -170,12 +170,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 8a4b012a1e734088a2d473f93e63d21606fcc8ec Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Sat, 4 Jan 2014 00:51:23 +0100 Subject: [PATCH 08/15] 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 ceb20a671c2c98be2b04e4b8b3db22c85b5d8cea Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Sat, 4 Jan 2014 11:11:25 +0100 Subject: [PATCH 09/15] 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 d60e051..4342162 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -170,22 +170,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 dd4c641405cf951da68eff740e10670d8c95d0d2 Mon Sep 17 00:00:00 2001 From: Schell Scivally Date: Mon, 6 Jan 2014 16:13:56 -0800 Subject: [PATCH 10/15] Updates for changes in GHC API. Fixes #24. Updates to GHC API Pretty.showDoc --- src/Info.hs | 39 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 37 insertions(+), 2 deletions(-) diff --git a/src/Info.hs b/src/Info.hs index b9dedb5..ffd3c96 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -16,6 +16,9 @@ import qualified Desugar #if __GLASGOW_HASKELL__ >= 706 import qualified DynFlags #endif +#if __GLASGOW_HASKELL__ >= 707 +import qualified HsExpr +#endif import qualified GHC import qualified HscTypes import qualified NameSet @@ -127,13 +130,22 @@ getSrcSpan (GHC.RealSrcSpan spn) = getSrcSpan _ = Nothing getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) +#if __GLASGOW_HASKELL__ >= 707 +getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = HsExpr.MG _ _ typ}) = return $ Just (spn, typ) +#else getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) +#endif getTypeLHsBind _ _ = return Nothing getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLHsExpr tcm e = do hs_env <- GHC.getSession +#if __GLASGOW_HASKELL__ >= 707 + let fm_inst_env = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcm + (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env e +#else (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e +#endif return () case mbe of Nothing -> return Nothing @@ -161,14 +173,22 @@ pretty dflags = pretty :: GHC.Type -> String pretty = #endif +#if __GLASGOW_HASKELL__ >= 708 + Pretty.showDoc Pretty.OneLineMode 1 +#else Pretty.showDocWith Pretty.OneLineMode +#endif #if __GLASGOW_HASKELL__ >= 706 . Outputable.withPprStyleDoc dflags #else . Outputable.withPprStyleDoc #endif (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) +#if __GLASGOW_HASKELL__ >= 707 + . PprTyThing.pprTypeForUser +#else . PprTyThing.pprTypeForUser False +#endif ------------------------------------------------------------------------------ -- The following was taken from 'ghc-syb-utils' @@ -198,8 +218,13 @@ everythingStaged stage k z f x infoThing :: String -> GHC.Ghc String infoThing str = do names <- GHC.parseName str +#if __GLASGOW_HASKELL__ >= 707 + mb_stuffs <- mapM (GHC.getInfo False) names + let filtered = filterOutChildren (\(t,_f,_i,_) -> t) (catMaybes mb_stuffs) +#else mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) +#endif unqual <- GHC.getPrintUnqual #if __GLASGOW_HASKELL__ >= 706 dflags <- DynFlags.getDynFlags @@ -207,7 +232,11 @@ infoThing str = do #else return $ Outputable.showSDocForUser unqual $ #endif +#if __GLASGOW_HASKELL__ >= 707 + Outputable.vcat (intersperse (Outputable.text "") $ map pprInfo filtered) +#else Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered) +#endif -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data @@ -225,13 +254,19 @@ filterOutChildren get_thing xs Just p -> GHC.getName p `NameSet.elemNameSet` all_names Nothing -> False -#if __GLASGOW_HASKELL__ >= 706 +#if __GLASGOW_HASKELL__ >= 707 +pprInfo :: (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst], [GHC.FamInst]) -> Outputable.SDoc +pprInfo (thing, fixity, insts, _) = + PprTyThing.pprTyThingInContextLoc thing +#elif __GLASGOW_HASKELL__ >= 706 pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst]) -> Outputable.SDoc +pprInfo pefas (thing, fixity, insts) = + PprTyThing.pprTyThingInContextLoc pefas thing #else pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc -#endif pprInfo pefas (thing, fixity, insts) = PprTyThing.pprTyThingInContextLoc pefas thing +#endif Outputable.$$ show_fixity fixity Outputable.$$ Outputable.vcat (map GHC.pprInstance insts) where From c2dc5db06e337bc2c742b962bbcd9403431792c6 Mon Sep 17 00:00:00 2001 From: Schell Scivally Date: Thu, 13 Feb 2014 10:11:42 -0800 Subject: [PATCH 11/15] Changed showDoc mode 1 to showDoc mode 0 --- src/Info.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Info.hs b/src/Info.hs index ffd3c96..b7556eb 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -174,7 +174,7 @@ pretty :: GHC.Type -> String pretty = #endif #if __GLASGOW_HASKELL__ >= 708 - Pretty.showDoc Pretty.OneLineMode 1 + Pretty.showDoc Pretty.OneLineMode 0 #else Pretty.showDocWith Pretty.OneLineMode #endif From 4ff36c55ed64a774067697d9830a490bb9028263 Mon Sep 17 00:00:00 2001 From: Schell Scivally Date: Thu, 17 Jul 2014 18:03:46 -0700 Subject: [PATCH 12/15] changes for GHC API 7.8.3 --- .gitignore | 2 ++ src/Info.hs | 16 ++++++++-------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/.gitignore b/.gitignore index 178135c..373259b 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,3 @@ /dist/ +.cabal-sandbox +cabal.sandbox.config diff --git a/src/Info.hs b/src/Info.hs index b7556eb..469a70c 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -16,7 +16,7 @@ import qualified Desugar #if __GLASGOW_HASKELL__ >= 706 import qualified DynFlags #endif -#if __GLASGOW_HASKELL__ >= 707 +#if __GLASGOW_HASKELL__ >= 708 import qualified HsExpr #endif import qualified GHC @@ -130,8 +130,8 @@ getSrcSpan (GHC.RealSrcSpan spn) = getSrcSpan _ = Nothing getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) -#if __GLASGOW_HASKELL__ >= 707 -getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = HsExpr.MG _ _ typ}) = return $ Just (spn, typ) +#if __GLASGOW_HASKELL__ >= 708 +getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = HsExpr.MG _ _ typ _}) = return $ Just (spn, typ) #else getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) #endif @@ -140,7 +140,7 @@ getTypeLHsBind _ _ = return Nothing getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLHsExpr tcm e = do hs_env <- GHC.getSession -#if __GLASGOW_HASKELL__ >= 707 +#if __GLASGOW_HASKELL__ >= 708 let fm_inst_env = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcm (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env e #else @@ -184,7 +184,7 @@ pretty = . Outputable.withPprStyleDoc #endif (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) -#if __GLASGOW_HASKELL__ >= 707 +#if __GLASGOW_HASKELL__ >= 708 . PprTyThing.pprTypeForUser #else . PprTyThing.pprTypeForUser False @@ -218,7 +218,7 @@ everythingStaged stage k z f x infoThing :: String -> GHC.Ghc String infoThing str = do names <- GHC.parseName str -#if __GLASGOW_HASKELL__ >= 707 +#if __GLASGOW_HASKELL__ >= 708 mb_stuffs <- mapM (GHC.getInfo False) names let filtered = filterOutChildren (\(t,_f,_i,_) -> t) (catMaybes mb_stuffs) #else @@ -232,7 +232,7 @@ infoThing str = do #else return $ Outputable.showSDocForUser unqual $ #endif -#if __GLASGOW_HASKELL__ >= 707 +#if __GLASGOW_HASKELL__ >= 708 Outputable.vcat (intersperse (Outputable.text "") $ map pprInfo filtered) #else Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered) @@ -254,7 +254,7 @@ filterOutChildren get_thing xs Just p -> GHC.getName p `NameSet.elemNameSet` all_names Nothing -> False -#if __GLASGOW_HASKELL__ >= 707 +#if __GLASGOW_HASKELL__ >= 708 pprInfo :: (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst], [GHC.FamInst]) -> Outputable.SDoc pprInfo (thing, fixity, insts, _) = PprTyThing.pprTyThingInContextLoc thing From f8eed72f86f7e2df24e7d344981023f740c9f909 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Thu, 6 Aug 2015 19:15:19 +0200 Subject: [PATCH 13/15] 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 5d045b4..2d5687e 100644 --- a/src/CommandArgs.hs +++ b/src/CommandArgs.hs @@ -164,7 +164,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 1108603557e16188b056890eaf8e3a5ffcd1ea20 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Fri, 7 Aug 2015 10:37:16 +0200 Subject: [PATCH 14/15] findsymbol: add support for ghc 7.10 --- hdevtools.cabal | 2 ++ src/CommandLoop.hs | 5 ++++- src/FindSymbol.hs | 32 ++++++++++++++++++++++++++------ 3 files changed, 32 insertions(+), 7 deletions(-) diff --git a/hdevtools.cabal b/hdevtools.cabal index 2c34b96..6ef7b45 100644 --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -66,3 +66,5 @@ executable hdevtools network, time, unix + if impl(ghc >= 7.9) + build-depends: bin-package-db diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 4342162..dde51af 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -7,6 +7,9 @@ module CommandLoop import Control.Monad (when) import Data.IORef import Data.List (find, intercalate) +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable (traverse) +#endif import MonadUtils (MonadIO, liftIO) import System.Exit (ExitCode(ExitFailure, ExitSuccess)) import qualified ErrUtils @@ -183,7 +186,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..a98bf86 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 = From b5fde578e1d586650a33ad5e765e378b8190e408 Mon Sep 17 00:00:00 2001 From: Daniel Trstenjak Date: Fri, 7 Aug 2015 15:11:19 +0200 Subject: [PATCH 15/15] info: add support for ghc 7.10 --- src/Info.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Info.hs b/src/Info.hs index 469a70c..289a711 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -18,6 +18,8 @@ import qualified DynFlags #endif #if __GLASGOW_HASKELL__ >= 708 import qualified HsExpr +#else +import qualified TcRnTypes #endif import qualified GHC import qualified HscTypes @@ -26,7 +28,6 @@ import qualified Outputable import qualified PprTyThing import qualified Pretty import qualified TcHsSyn -import qualified TcRnTypes getIdentifierInfo :: FilePath -> String -> GHC.Ghc (Either String String) getIdentifierInfo file identifier = @@ -131,29 +132,31 @@ getSrcSpan _ = Nothing getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) #if __GLASGOW_HASKELL__ >= 708 -getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = HsExpr.MG _ _ typ _}) = return $ Just (spn, typ) +getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = grp}) = return $ Just (spn, HsExpr.mg_res_ty grp) #else getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) #endif getTypeLHsBind _ _ = return Nothing getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) +#if __GLASGOW_HASKELL__ >= 708 +getTypeLHsExpr _ e = do +#else getTypeLHsExpr tcm e = do +#endif hs_env <- GHC.getSession #if __GLASGOW_HASKELL__ >= 708 - let fm_inst_env = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcm (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env e #else + let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module tcm + rn_env = TcRnTypes.tcg_rdr_env $ fst $ GHC.tm_internals_ tcm + ty_env = TcRnTypes.tcg_type_env $ fst $ GHC.tm_internals_ tcm (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e #endif return () case mbe of Nothing -> return Nothing Just expr -> return $ Just (GHC.getLoc e, CoreUtils.exprType expr) - where - modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module tcm - rn_env = TcRnTypes.tcg_rdr_env $ fst $ GHC.tm_internals_ tcm - ty_env = TcRnTypes.tcg_type_env $ fst $ GHC.tm_internals_ tcm getTypeLPat :: GHC.TypecheckedModule -> GHC.LPat GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLPat _ (GHC.L spn pat) = return $ Just (spn, TcHsSyn.hsPatType pat) @@ -208,7 +211,11 @@ everythingStaged stage k z f x | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet.NameSet -> Bool +#if __GLASGOW_HASKELL__ >= 709 + postTcType = const (stage Bool +#else postTcType = const (stage Bool +#endif fixity = const (stage Bool ------------------------------------------------------------------------------