Add command 'findsymbol'

.gitignore

@@ -1 +1,3 @@
 /dist/
+.cabal-sandbox
+cabal.sandbox.config

hdevtools.cabal

@@ -66,3 +66,5 @@ executable hdevtools
                        network,
                        time,
                        unix
+  if impl(ghc >= 7.9)
+    build-depends:     bin-package-db

src/CommandArgs.hs

@@ -62,6 +62,12 @@ data HDevTools
         , line :: Int
         , col :: Int
         }
+    | FindSymbol
+        { socket :: Maybe FilePath
+        , ghcOpts :: [String]
+        , symbol :: String
+        , files :: [String]
+        }
     deriving (Show, Data, Typeable)
 
 dummyAdmin :: HDevTools
@@ -104,6 +110,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"
@@ -144,8 +158,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

@@ -6,7 +6,10 @@ 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
 import MonadUtils (MonadIO, liftIO)
 import System.Exit (ExitCode(ExitFailure, ExitSuccess))
 import qualified ErrUtils
@@ -17,6 +20,7 @@ import qualified Outputable
 
 import Types (ClientDirective(..), Command(..))
 import Info (getIdentifierInfo, getType)
+import FindSymbol (findSymbol)
 
 type CommandObj = (Command, [String])
 
@@ -168,6 +172,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/Info.hs

@@ -16,14 +16,18 @@ import qualified Desugar
 #if __GLASGOW_HASKELL__ >= 706
 import qualified DynFlags
 #endif
+#if __GLASGOW_HASKELL__ >= 708
+import qualified HsExpr
+#else
+import qualified TcRnTypes
+#endif
 import qualified GHC
 import qualified HscTypes
 import qualified NameSet
 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 =
@@ -127,21 +131,32 @@ getSrcSpan (GHC.RealSrcSpan spn) =
 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 = 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
+    (_, 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)
@@ -161,14 +176,22 @@ pretty dflags =
 pretty :: GHC.Type -> String
 pretty =
 #endif
+#if __GLASGOW_HASKELL__ >= 708
+    Pretty.showDoc Pretty.OneLineMode 0
+#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__ >= 708
+    . PprTyThing.pprTypeForUser
+#else
     . PprTyThing.pprTypeForUser False
+#endif
 
 ------------------------------------------------------------------------------
 -- The following was taken from 'ghc-syb-utils'
@@ -188,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<TypeChecker)                 :: GHC.PostTc GHC.Id GHC.Type -> Bool
+#else
         postTcType = const (stage<TypeChecker)                 :: GHC.PostTcType -> Bool
+#endif
         fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool
 
 ------------------------------------------------------------------------------
@@ -198,16 +225,25 @@ everythingStaged stage k z f x
 infoThing :: String -> GHC.Ghc String
 infoThing str = do
     names <- GHC.parseName str
+#if __GLASGOW_HASKELL__ >= 708
+    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
     return $ Outputable.showSDocForUser dflags unqual $
 #else
     return $ Outputable.showSDocForUser unqual $
 #endif
+#if __GLASGOW_HASKELL__ >= 708
+        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 +261,19 @@ filterOutChildren get_thing xs
                      Just p  -> GHC.getName p `NameSet.elemNameSet` all_names
                      Nothing -> False
 
-#if __GLASGOW_HASKELL__ >= 706
+#if __GLASGOW_HASKELL__ >= 708
+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

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) (files args)) (ghcOpts args)

src/Types.hs

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