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/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/CommandArgs.hs b/src/CommandArgs.hs index 2149b29..2d5687e 100644 --- a/src/CommandArgs.hs +++ b/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 diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 1a62ca3..dde51af 100644 --- a/src/CommandLoop.hs +++ b/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 () diff --git a/src/FindSymbol.hs b/src/FindSymbol.hs new file mode 100644 index 0000000..a98bf86 --- /dev/null +++ b/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) diff --git a/src/Info.hs b/src/Info.hs index b9dedb5..289a711 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -16,6 +16,11 @@ 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 @@ -23,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 = @@ -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 Bool +#else postTcType = const (stage Bool +#endif fixity = const (stage Bool ------------------------------------------------------------------------------ @@ -198,8 +225,13 @@ 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 @@ -207,7 +239,11 @@ infoThing str = do #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 diff --git a/src/Main.hs b/src/Main.hs index 517f224..d650328 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) (files args)) (ghcOpts args) diff --git a/src/Types.hs b/src/Types.hs index 9b50707..3511a39 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 [String] deriving (Read, Show)