hsinspect 0.0.4 → 0.0.5
raw patch · 8 files changed
+76/−76 lines, 8 filesdep −ghc-paths
Dependencies removed: ghc-paths
Files
- exe/Main.hs +3/−4
- hsinspect.cabal +2/−2
- library/HsInspect/Imports.hs +5/−1
- library/HsInspect/Modules.hs +1/−0
- library/HsInspect/Packages.hs +2/−24
- library/HsInspect/Plugin.hs +2/−1
- library/HsInspect/Search.hs +35/−44
- library/HsInspect/Util.hs +26/−0
exe/Main.hs view
@@ -8,10 +8,9 @@ import Control.Monad import Control.Monad.IO.Class import Data.Char (isUpper)-import Data.List (isPrefixOf)+import Data.List (find, isPrefixOf) import DynFlags (parseDynamicFlagsCmdLine, updOptLevel) import qualified GHC as GHC-import GHC.Paths (libdir) import HsInspect.Imports import HsInspect.Modules import HsInspect.Packages@@ -51,8 +50,8 @@ (putStrLn help) >> exitWith ExitSuccess when (elem "--version" args) $ (putStrLn version) >> exitWith ExitSuccess- -- TODO require a -B flag instead of the ghc-paths dependency- GHC.runGhc (Just libdir) $ do+ let libdir = (drop 2) <$> find ("-B" `isPrefixOf`) flags+ GHC.runGhc libdir $ do dflags <- GHC.getSessionDynFlags (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> ghcargs, _) <- liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags)
hsinspect.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hsinspect-version: 0.0.4+version: 0.0.5 synopsis: Inspect Haskell source files. license: GPL-3.0-or-later license-file: LICENSE@@ -34,7 +34,6 @@ import: deps hs-source-dirs: exe build-depends:- , ghc-paths , hsinspect main-is: Main.hs@@ -52,4 +51,5 @@ HsInspect.Plugin HsInspect.Search HsInspect.Sexp+ HsInspect.Util HsInspect.Workarounds
library/HsInspect/Imports.hs view
@@ -2,7 +2,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -module HsInspect.Imports where+module HsInspect.Imports+ ( imports,+ Qualified,+ )+where import Data.Maybe (fromJust) import DynFlags (unsafeGlobalDynFlags)
library/HsInspect/Modules.hs view
@@ -3,6 +3,7 @@ -- | Calculate all exposed modules that could be imported. module HsInspect.Modules ( modules,+ Hit, ) where
library/HsInspect/Packages.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -module HsInspect.Packages (packages) where+module HsInspect.Packages (packages, PkgSummary) where import BasicTypes (StringLiteral(..)) import Control.Monad (join, void)@@ -16,11 +16,11 @@ 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 System.Directory (doesDirectoryExist, listDirectory) -- Similar to packunused / weeder, but more reliable (and doesn't require a -- separate -ddump-minimal-imports pass).@@ -82,27 +82,6 @@ qModule (GHC.XImportDecl _) = Nothing #endif -walk :: FilePath -> IO [FilePath]-walk dir = do- isDir <- doesDirectoryExist dir- if isDir- then do fs <- listDirectory dir- let base = dir <> "/"- qfs = (base <>) <$> fs- concatMapM walk qfs- else pure [dir]---- from extra-concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM op = foldr f (pure [])- where f x xs = do- x' <- op x- if null x'- then xs- else do- xs' <- xs- pure $ x' ++ xs'- data PkgSummary = PkgSummary [GHC.UnitId] [GHC.UnitId] deriving (Eq, Ord) @@ -117,4 +96,3 @@ JSObject [ ("used", toJ used) , ("unused", toJ unused) ] where toJ ids = JSArray $ JSString . unitIdString <$> ids-
library/HsInspect/Plugin.hs view
@@ -22,7 +22,8 @@ plugin :: GHC.Plugin plugin = GHC.defaultPlugin- { GHC.installCoreToDos = install+ { GHC.installCoreToDos = install,+ GHC.pluginRecompile = GHC.purePlugin } install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo]
library/HsInspect/Search.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-} -module HsInspect.Search where+module HsInspect.Search+ ( search,+ Hit,+ )+where import BinIface ( CheckHiWay (..),@@ -9,64 +14,50 @@ ) import Control.Monad import Control.Monad.IO.Class-import Data.Maybe-import Finder (findExposedPackageModule)+import Data.List (isSuffixOf)+import qualified Data.Set as Set import qualified GHC import GHC.PackageDb import HsInspect.Sexp-import HscTypes (FindResult (..), ModIface (..))+import HsInspect.Util+import HscTypes (ModIface (..)) import Json-import Module (ModLocation (..), Module (..), unitIdFS) import PackageConfig-import Packages (LookupResult (..))+import Packages (explicitPackages) import TcRnMonad (initTcRnIf) search :: GHC.GhcMonad m => String -> m [Hit]-search _query = do+search query = do+ liftIO . putStrLn . show $ "SEARCH: " <> query+ -- TODO support home modules dflags <- GHC.getSessionDynFlags- let Just dbs = GHC.pkgDatabase dflags- pkgs = join (snd <$> dbs)- join <$> traverse getHits pkgs + -- 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+ symbols <- join <$> traverse getSymbols pkgs+ pure $ Hit <$> symbols+ -- ^ TODO filter and rank the symbols by the search+ -- TODO Maybe haddock-html-getHits :: GHC.GhcMonad m => PackageConfig -> m [Hit]-getHits pkg = do- results <- traverse finder (lookups pkg)- join <$> traverse toHit results+getSymbols :: GHC.GhcMonad m => PackageConfig -> m [String]+getSymbols pkg = do+ let findHis dir = do+ liftIO . putStrLn . show $ "WALKING: " <> dir+ filter (".hi" `isSuffixOf`) <$> liftIO (walk dir)+ his <- join <$> traverse findHis (importDirs pkg)+ join <$> traverse hiToSymbols his --- FIXME finder doesn't work. It probably needs everything to be loaded. Just--- traverse the library directories looking for .hi files and filter the modules--- based on the exported list. That should avoid the risk of compiling anything.-toHit :: GHC.GhcMonad m => FindResult -> m [Hit]-toHit (Found (ModLocation _ hi _) _) = do+-- TODO filter out hidden modules+hiToSymbols :: GHC.GhcMonad m => FilePath -> m [String]+hiToSymbols hi = do+ liftIO . putStrLn . show $ "PARSING: " <> hi env <- GHC.getSession iface <- liftIO $ initTcRnIf 'z' env () () $ readBinIface IgnoreHiWay QuietBinIFaceReading hi- pure [Hit . show . length $ mi_exports iface]-toHit _ = pure []---- LookupFound Module PackageConfig--- findLookupResult--- findExposedPackageModule--- lookupIfaceByModule--- showIface--- readBinIface-finder :: GHC.GhcMonad m => LookupResult -> m FindResult-finder lup = do- env <- GHC.getSession- liftIO $ findLookupResult env lup---- TODO ghc should export Finder.findLookupResult-findLookupResult :: GHC.HscEnv -> LookupResult -> IO FindResult-findLookupResult env (LookupFound (Module mid name) _) =- findExposedPackageModule env name (Just $ unitIdFS mid)-findLookupResult _ _ = error "not supported"--lookups :: PackageConfig -> [LookupResult]-lookups c@InstalledPackageInfo {exposedModules} =- let modules = catMaybes $ snd <$> exposedModules- in flip LookupFound c <$> modules+ pure [show . length $ mi_exports iface] data Hit = Hit String @@ -74,4 +65,4 @@ toSexp (Hit txt) = toSexp txt instance ToJson Hit where- json (Hit _) = error "not implemented yet"+ json (Hit txt) = JSString txt
+ library/HsInspect/Util.hs view
@@ -0,0 +1,26 @@+module HsInspect.Util where++import System.Directory (doesDirectoryExist, listDirectory)++walk :: FilePath -> IO [FilePath]+walk dir = do+ isDir <- doesDirectoryExist dir+ if isDir+ then do+ fs <- listDirectory dir+ let base = dir <> "/"+ qfs = (base <>) <$> fs+ concatMapM walk qfs+ else pure [dir]++-- from extra+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM op = foldr f (pure [])+ where+ f x xs = do+ x' <- op x+ if null x'+ then xs+ else do+ xs' <- xs+ pure $ x' ++ xs'