hsinspect 0.0.6 → 0.0.7
raw patch · 8 files changed
+202/−181 lines, 8 files
Files
- exe/Main.hs +17/−22
- hsinspect.cabal +4/−4
- library/HsInspect/Imports.hs +8/−4
- library/HsInspect/Index.hs +139/−0
- library/HsInspect/Modules.hs +0/−44
- library/HsInspect/Packages.hs +15/−15
- library/HsInspect/Search.hs +0/−73
- library/HsInspect/Workarounds.hs +19/−19
exe/Main.hs view
@@ -5,21 +5,20 @@ module Main where -import Control.Monad-import Control.Monad.IO.Class-import Data.Char (isUpper)-import Data.List (find, isPrefixOf)-import DynFlags (parseDynamicFlagsCmdLine, updOptLevel)+import Control.Monad+import Control.Monad.IO.Class+import Data.Char (isUpper)+import Data.List (find, isPrefixOf)+import DynFlags (parseDynamicFlagsCmdLine, updOptLevel) import qualified GHC as GHC-import HsInspect.Imports-import HsInspect.Modules-import HsInspect.Packages-import HsInspect.Search-import HsInspect.Sexp as S-import Json-import Outputable (defaultUserStyle, initSDocContext, runSDoc)-import System.Environment (getArgs)-import System.Exit+import HsInspect.Imports+import HsInspect.Index+import HsInspect.Packages+import HsInspect.Sexp as S+import Json+import Outputable (defaultUserStyle, initSDocContext, runSDoc)+import System.Environment (getArgs)+import System.Exit version :: String #ifdef CURRENT_PACKAGE_VERSION@@ -35,9 +34,8 @@ " imports /path/to/file.hs - list the qualified imports for the file\n" ++ " along with their locally qualified (and\n" ++ " unqualified) names.\n" ++- " modules /path/to/file.hs - list all modules that could be imported by file.\n" ++- " packages /path/to/dir - list all packages that are imported by this dir.\n" ++- " search /path/to/file.hs QUERY - Hoogle query within the file's context.\n "+ " index - list all dependency packages, modules, terms and types.\n" +++ " packages /path/to/dir - list all packages that are referenced by sources in this dir.\n" -- Possible backends: --@@ -73,14 +71,11 @@ "imports" : file : rest -> do quals <- imports file respond rest quals- "modules" : rest -> do- hits <- modules homeModules+ "index" : rest -> do+ hits <- index respond rest hits "packages" : dir : rest -> do hits <- packages dir- respond rest hits- "search" : query : rest -> do- hits <- search query respond rest hits _ -> liftIO $ error "invalid parameters"
hsinspect.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hsinspect-version: 0.0.6+version: 0.0.7 synopsis: Inspect Haskell source files. license: GPL-3.0-or-later license-file: LICENSE@@ -34,8 +34,9 @@ ghc-options: -Wall -Werror=missing-home-modules default-language: Haskell2010+ if flag(ghcflags)- ghc-options: -fplugin GhcFlags.Plugin+ ghc-options: -fplugin GhcFlags.Plugin build-depends: ghcflags executable hsinspect@@ -52,9 +53,8 @@ -- cabal-fmt: expand library exposed-modules: HsInspect.Imports- HsInspect.Modules+ HsInspect.Index HsInspect.Packages- HsInspect.Search HsInspect.Sexp HsInspect.Util HsInspect.Workarounds
library/HsInspect/Imports.hs view
@@ -62,13 +62,17 @@ in Qualified ln lqn fqn -- Note that `nameSrcLoc gre_name` is empty--- TODO what other information is available?+-- TODO unitid (can be used to lookup source code) -- TODO "and originally defined" / ppr_defn_site++-- 1. local name+-- 2. locally qualified name+-- 3. fully qualified name data Qualified = Qualified- (Maybe String) -- ^^ local name- (Maybe String) -- ^^ locally qualifed name- String -- ^^ fully qualified name+ (Maybe String)+ (Maybe String)+ String deriving (Eq, Show) instance ToSexp Qualified where
+ library/HsInspect/Index.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++-- | Dumps an index of all terms and their types+module HsInspect.Index+ ( index,+ PackageEntries,+ )+where++import Avail (AvailInfo (..))+import BinIface+ ( CheckHiWay (..),+ TraceBinIFaceReading (..),+ readBinIface,+ )+import Control.Monad+import Control.Monad.IO.Class+import Data.List (isSuffixOf)+import Data.Maybe (catMaybes, maybeToList)+import Data.Set (Set)+import qualified Data.Set as Set+import qualified GHC+import GHC.PackageDb+import HsInspect.Sexp+import HsInspect.Util+import HscTypes (ModIface (..))+import qualified Id as GHC+import Json+import Module (Module (..), moduleNameString, unitIdString)+import Outputable (showPpr)+import PackageConfig+--import System.IO (hPutStrLn, stderr)+import PackageConfig (packageConfigId)+import Packages (explicitPackages, lookupPackage)+import TcEnv (tcLookup)+import TcRnMonad (initTcInteractive)+import qualified TcRnTypes as GHC++index :: GHC.GhcMonad m => m [PackageEntries]+index = do+ -- TODO the home package+ dflags <- GHC.getSessionDynFlags+ let explicit = explicitPackages $ GHC.pkgState dflags+ pkgcfgs = maybeToList . lookupPackage dflags =<< explicit+ traverse getSymbols pkgcfgs++-- TODO Maybe haddock-html+-- TODO Maybe source definition (or should we leave source resolution to downstream?)+getSymbols :: GHC.GhcMonad m => PackageConfig -> m PackageEntries+getSymbols pkg = do+ let findHis dir = filter (".hi" `isSuffixOf`) <$> liftIO (walk dir)+ exposed = Set.fromList $ fst <$> exposedModules pkg+ unitid = packageConfigId pkg+ his <- join <$> traverse findHis (importDirs pkg)+ PackageEntries unitid . catMaybes <$> traverse (hiToSymbols exposed) his++hiToSymbols :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe ModuleEntries)+hiToSymbols exposed hi = do+ env <- GHC.getSession+ dflags <- GHC.getSessionDynFlags+ (_, hits) <-+ -- TODO use initTc instead of initTcInteractive+ liftIO . initTcInteractive env $ do+ iface <- readBinIface IgnoreHiWay QuietBinIFaceReading hi+ let m = mi_module iface+ modName = moduleName m+ if not $ Set.member (GHC.moduleName m) exposed+ then pure Nothing+ else do+ let thing (Avail name) = traverse tcLookup [name]+ -- TODO the fields in AvailTC+ thing (AvailTC name members _) = traverse tcLookup (name : members)++ things <- join <$> traverse thing (mi_exports iface)++ -- TODO refactor this code to return the Module and TcTyThing and+ -- do the conversion to Entry in the caller.+ pure . Just . ModuleEntries modName . catMaybes $ (tyrender dflags) <$> things+ pure $ join hits++tyrender :: GHC.DynFlags -> GHC.TcTyThing -> Maybe Entry+tyrender dflags (GHC.AGlobal (GHC.AnId var)) =+ Just+ $ Entry (showPpr dflags $ GHC.idName var)+ (showPpr dflags $ GHC.idType var)+-- TODO investigate what we're skipping+tyrender _ _ = Nothing++-- TODO normalise the type string to make it easier for downstream tools to perform searches+-- TODO note if this is the original definition point (vs a re-export)+data Entry = Entry String String++data ModuleEntries = ModuleEntries GHC.ModuleName [Entry]++data PackageEntries = PackageEntries GHC.UnitId [ModuleEntries]++instance ToSexp Entry where+ toSexp (Entry term typ) =+ alist+ [ ("name", SexpString term),+ ("type", SexpString typ)+ ]++instance ToSexp ModuleEntries where+ toSexp (ModuleEntries modl entries) =+ alist+ [ ("module", SexpString . moduleNameString $ modl),+ ("ids", toSexp entries)+ ]++instance ToSexp PackageEntries where+ toSexp (PackageEntries pkg modules) =+ alist+ [ ("unitid", SexpString . unitIdString $ pkg),+ ("modules", toSexp modules)+ ]++instance ToJson Entry where+ json (Entry term typ) =+ JSObject+ [ ("name", JSString term),+ ("type", JSString typ)+ ]++instance ToJson ModuleEntries where+ json (ModuleEntries modl entries) =+ JSObject+ [ ("module", JSString . moduleNameString $ modl),+ ("ids", JSArray $ json <$> entries)+ ]++instance ToJson PackageEntries where+ json (PackageEntries pkg modules) =+ JSObject+ [ ("unitid", JSString . unitIdString $ pkg),+ ("modules", JSArray $ json <$> modules)+ ]
− library/HsInspect/Modules.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}---- | Calculate all exposed modules that could be imported.-module HsInspect.Modules- ( modules,- Hit,- )-where--import Data.List (sort)-import Data.Set (Set)-import qualified Data.Set as Set-import qualified GHC-import GHC.PackageDb-import HsInspect.Sexp-import Json-import Module (UnitId)-import PackageConfig-import Packages (explicitPackages)--modules :: GHC.GhcMonad m => [String] -> m [Hit]-modules homeModules = do- -- TODO where is base?- dflags <- GHC.getSessionDynFlags- let Just dbs = GHC.pkgDatabase dflags- loaded = Set.fromList . explicitPackages $ GHC.pkgState dflags- home = Hit <$> homeModules- away = (mods loaded =<<) =<< (snd <$> dbs)- pure . sort $ home <> away--mods :: Set UnitId -> PackageConfig -> [Hit]-mods allowed p =- if Set.notMember (packageConfigId p) allowed- then []- else Hit . GHC.moduleNameString . fst <$> exposedModules p--data Hit = Hit String- deriving (Eq, Ord)--instance ToSexp Hit where- toSexp (Hit txt) = toSexp txt--instance ToJson Hit where- json (Hit txt) = JSString txt
library/HsInspect/Packages.hs view
@@ -5,27 +5,27 @@ module HsInspect.Packages (packages, PkgSummary) where -import BasicTypes (StringLiteral(..))-import Control.Monad (join, void)-import Control.Monad.IO.Class (liftIO)-import Data.List (isSuffixOf, nub, sort, (\\))-import Data.Maybe (catMaybes)+import BasicTypes (StringLiteral(..))+import Control.Monad (join, void)+import Control.Monad.IO.Class (liftIO)+import Data.List (isSuffixOf, nub, sort, (\\))+import Data.Maybe (catMaybes) import qualified Data.Set as Set-import FastString-import Finder (findImportedModule)+import FastString+import Finder (findImportedModule) import qualified GHC-import HscTypes (FindResult(..))-import HsInspect.Sexp-import HsInspect.Util-import HsInspect.Workarounds-import Json-import Module (Module(..), ModuleName, moduleNameString, unitIdString)-import Packages (PackageState(..))+import HscTypes (FindResult(..))+import HsInspect.Sexp+import HsInspect.Util+import HsInspect.Workarounds+import Json+import Module (Module(..), ModuleName, moduleNameString, unitIdString)+import Packages (PackageState(..)) -- Similar to packunused / weeder, but more reliable (and doesn't require a -- separate -ddump-minimal-imports pass). ----- TODO support list of dirs not just one+-- TODO get the dirs from the dynflags not the user packages :: GHC.GhcMonad m => FilePath -> m PkgSummary packages dir = do -- We load all .hs files in dir, assuming they are the sources of the home
− library/HsInspect/Search.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ViewPatterns #-}--module HsInspect.Search- ( search,- Hit,- )-where--import BinIface- ( CheckHiWay (..),- TraceBinIFaceReading (..),- readBinIface,- )-import Control.Monad-import Control.Monad.IO.Class-import Data.List (isSuffixOf)-import Data.Set (Set)-import qualified Data.Set as Set-import qualified GHC-import GHC.PackageDb-import HsInspect.Sexp-import HsInspect.Util-import HscTypes (ModIface (..))-import Json-import qualified Name as GHC-import PackageConfig-import Packages (explicitPackages)-import TcRnMonad (initTcRnIf)--search :: GHC.GhcMonad m => String -> m [Hit]-search _query = do- -- TODO support home modules- -- TODO where is base?- dflags <- GHC.getSessionDynFlags-- -- TODO this logic is used in Packages / Modules, share- let Just ((snd =<<) -> allPkgs) = GHC.pkgDatabase dflags- explicit = Set.fromList . explicitPackages $ GHC.pkgState dflags- pkgs = filter (\(packageConfigId -> pid) -> Set.member pid explicit) allPkgs- join <$> traverse getSymbols pkgs- -- ^ TODO filter and rank the symbols by the search---- TODO Maybe haddock-html-getSymbols :: GHC.GhcMonad m => PackageConfig -> m [Hit]-getSymbols pkg = do- let findHis dir = filter (".hi" `isSuffixOf`) <$> liftIO (walk dir)- exposed = Set.fromList $ fst <$> exposedModules pkg- his <- join <$> traverse findHis (importDirs pkg)- join <$> traverse (hiToSymbols exposed) his--hiToSymbols :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m [Hit]-hiToSymbols exposed hi = do- env <- GHC.getSession- iface <-- liftIO $ initTcRnIf 'z' env () ()- $ readBinIface IgnoreHiWay QuietBinIFaceReading hi- let m = mi_module iface- pure- $ if not $ Set.member (GHC.moduleName m) exposed- then []- else do- -- FIXME the Name is not very useful, use loadDecls- decl <- GHC.getName . snd <$> mi_decls iface- pure $ Hit m decl--data Hit = Hit GHC.Module GHC.Name--instance ToSexp Hit where- toSexp (Hit _ name) = toSexp . GHC.getOccString $ name--instance ToJson Hit where- json (Hit _ name) = JSString . GHC.getOccString $ name
library/HsInspect/Workarounds.hs view
@@ -4,27 +4,27 @@ module HsInspect.Workarounds where -import Control.Monad-import Control.Monad.IO.Class-import Data.List (delete, intercalate, isSuffixOf)-import Data.Set (Set)+import Control.Monad+import Control.Monad.IO.Class+import Data.List (delete, intercalate, isSuffixOf)+import Data.Set (Set) import qualified Data.Set as Set-import DriverPhases (HscSource(..), Phase(..))-import DriverPipeline (preprocess)-import DynFlags (parseDynamicFilePragma)-import FastString+import DriverPhases (HscSource(..), Phase(..))+import DriverPipeline (preprocess)+import DynFlags (parseDynamicFilePragma)+import FastString import qualified GHC as GHC-import HeaderInfo (getOptions)-import HscTypes (Target(..), TargetId(..))-import HsImpExp (ImportDecl(..))-import Lexer-import Outputable (showPpr)-import Parser (parseHeader)-import RdrName (GlobalRdrEnv)-import SrcLoc-import StringBuffer-import System.Directory (getModificationTime, removeFile)-import TcRnTypes (tcg_rdr_env)+import HeaderInfo (getOptions)+import HscTypes (Target(..), TargetId(..))+import HsImpExp (ImportDecl(..))+import Lexer+import Outputable (showPpr)+import Parser (parseHeader)+import RdrName (GlobalRdrEnv)+import SrcLoc+import StringBuffer+import System.Directory (getModificationTime, removeFile)+import TcRnTypes (tcg_rdr_env) -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541 importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, Target)