Merge pull request bitc#13 from dan-t/findsymbol_command

Findsymbol command
:+1:

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

src/CommandArgs.hs

@@ -76,6 +76,12 @@ data HDevTools
         , line    :: Int
         , col     :: Int
         }
+    | FindSymbol
+        { socket :: Maybe FilePath
+        , ghcOpts :: [String]
+        , symbol :: String
+        , files :: [String]
+        }
     deriving (Show, Data, Typeable)
 
 dummyAdmin :: HDevTools
@@ -121,6 +127,14 @@ dummyType = Type
     , col     = 0
     }
 
+dummyFindSymbol :: HDevTools
+dummyFindSymbol = FindSymbol
+    { socket = Nothing
+    , ghcOpts = []
+    , symbol = ""
+    , files = []
+    }
+
 admin :: Annotate Ann
 admin = record dummyAdmin
     [ socket       := def += typFile += help "socket file to use"
@@ -164,8 +178,16 @@ 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
+    , files    := def += typFile += args
+    ] += help "List the modules where the given symbol could be found"
+
 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

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
@@ -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,21 @@ runCommand state clientSend (CmdType file (line, col)) = do
             , show endCol , " "
             , "\"", t, "\""
             ]
+runCommand state clientSend (CmdFindSymbol symbol files) = do
+    result <- withWarnings state False $ findSymbol symbol files
+    case result of
+        []      -> liftIO $ mapM_ clientSend
+                       [ ClientStderr $ "Couldn't find modules containing '" ++ symbol ++ "'"
+                       , ClientExit (ExitFailure 1)
+                       ]
+        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 ()

src/FindSymbol.hs

@@ -0,0 +1,99 @@
+{-# 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 Packages as PKG
+import qualified Name
+import Exception (ghandle)
+
+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
+   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
+   allExposedModules :: GHC.Ghc [GHC.Module]
+   allExposedModules = do
+      modNames <- exposedModuleNames
+      catMaybes <$> mapM findModule modNames
+      where
+      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 =
+         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)

src/Main.hs

@@ -35,13 +35,15 @@ 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
 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

src/Types.hs

@@ -38,4 +38,5 @@ data Command
     | CmdModuleFile String
     | CmdInfo FilePath String
     | CmdType FilePath (Int, Int)
+    | CmdFindSymbol String [String]
     deriving (Read, Show)