hsinspect 0.0.8 → 0.0.9

raw patch · 6 files changed

+67/−47 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hsinspect.cabal +1/−1
• library/HsInspect/Index.hs +52/−26
• library/HsInspect/Json.hs +2/−3
• library/HsInspect/Packages.hs +8/−4
• library/HsInspect/Sexp.hs +4/−0
• library/HsInspect/Util.hs +0/−13

@@ -1,6 +1,6 @@ cabal-version: 2.2 name:          hsinspect-version:       0.0.8+version:       0.0.9 synopsis:      Inspect Haskell source files. license:       GPL-3.0-or-later license-file:  LICENSE

@@ -1,7 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}  -- | Dumps an index of all terms and their types module HsInspect.Index@@ -15,11 +14,14 @@ import qualified ConLike as GHC import Control.Monad import Control.Monad.IO.Class+import Data.Coerce+import Data.List (isInfixOf) import Data.Maybe (catMaybes, mapMaybe, maybeToList) import Data.Set (Set) import qualified Data.Set as Set import qualified DataCon as GHC import qualified DynFlags as GHC+import FastString (unpackFS) import qualified GHC import GHC.PackageDb import qualified GHC.PackageDb as GHC@@ -29,13 +31,15 @@ import HsInspect.Util import qualified Id as GHC import Module (Module(..), moduleNameString)+import Module as GHC import qualified Name as GHC-import Outputable (showPpr)+import Outputable (showPpr, showSDoc) import qualified Outputable as GHC import PackageConfig import qualified PackageConfig as GHC-import Packages (explicitPackages, lookupPackage)+import Packages (explicitPackages, getPackageDetails, lookupPackage) --import System.IO (hPutStrLn, stderr)+import qualified PatSyn as GHC import TcEnv (tcLookup) import TcRnMonad (initTcInteractive) import qualified TcRnTypes as GHC@@ -53,7 +57,7 @@   let unitid = GHC.thisPackage dflags       dirs = maybeToList $ GHC.hiDir dflags   home_mods <- getTargetModules-  home_entries <- getSymbols unitid [] home_mods dirs+  home_entries <- getSymbols unitid True [] home_mods dirs    pure $ home_entries : deps @@ -98,23 +102,23 @@ getPkgSymbols :: GHC.GhcMonad m => PackageConfig -> m PackageEntries getPkgSymbols pkg =   let unitid = GHC.packageConfigId pkg+      inplace = "-inplace" `isInfixOf` (GHC.unitIdString unitid)       exposed = Set.fromList $ fst <$> exposedModules pkg       dirs = (importDirs pkg)       haddocks = GHC.haddockHTMLs pkg-   in if Set.null exposed || null dirs-        then pure $ PackageEntries unitid [] haddocks-        else getSymbols unitid haddocks exposed dirs+   in getSymbols unitid inplace haddocks exposed dirs -getSymbols :: GHC.GhcMonad m => GHC.UnitId -> [FilePath] -> Set GHC.ModuleName -> [FilePath] -> m PackageEntries-getSymbols unitid haddocks exposed dirs = do+getSymbols :: GHC.GhcMonad m => UnitId -> Bool -> [FilePath] -> Set GHC.ModuleName -> [FilePath] -> m PackageEntries+getSymbols unitid inplace haddocks exposed dirs = do   let findHis dir = liftIO $ walkSuffix ".hi" dir   his <- join <$> traverse findHis dirs   dflags <- GHC.getSessionDynFlags+  let srcid = sourcePackageId $ getPackageDetails dflags unitid   symbols <- catMaybes <$> traverse (hiToSymbols exposed) his   let entries = uncurry mkEntries <$> symbols       mkEntries m things = ModuleEntries (moduleName m) (renderThings things)-      renderThings things = catMaybes $ (uncurry $ tyrender dflags) <$> things-  pure $ PackageEntries unitid entries haddocks+      renderThings things = catMaybes $ (uncurry $ tyrender dflags unitid) <$> things+  pure $ PackageEntries srcid inplace entries haddocks  -- for a .hi file returns the module and a list of all things (with types -- resolved) in that module and their original module if they are re-exported.@@ -138,9 +142,10 @@       things <- join <$> traverse thing (mi_exports iface)       pure . Just $ (m, things) -tyrender :: GHC.DynFlags -> Maybe GHC.Module -> GHC.TcTyThing -> Maybe Entry-tyrender dflags ((Mod <$>) -> m) (GHC.AGlobal thing) =+tyrender :: GHC.DynFlags -> UnitId -> Maybe GHC.Module -> GHC.TcTyThing -> Maybe Entry+tyrender dflags unitid m' (GHC.AGlobal thing) =   let+    m = mkExported dflags unitid <$> m'     shw :: GHC.Outputable m => m -> String     shw = showPpr dflags    in case thing of@@ -150,16 +155,19 @@     (GHC.AConLike (GHC.RealDataCon dc)) -> Just $ ConEntry m       (shw $ GHC.getName dc)       (shw $ GHC.dataConUserType dc) -- TODO fully qualify-    -- TODO PatSynCon+    (GHC.AConLike (GHC.PatSynCon ps)) -> Just $ PatSynEntry m+      (shw $ GHC.getName ps)+      (showSDoc dflags $ GHC.pprPatSynType ps )     (GHC.ATyCon tc) -> Just $ TyConEntry m       (shw $ GHC.tyConName tc)       (shw $ GHC.tyConFlavour tc)     _ -> Nothing-tyrender _ _ _ = Nothing+tyrender _ _ _ _ = Nothing -data Entry = IdEntry (Maybe Mod) String String -- ^ name type-           | ConEntry (Maybe Mod) String String -- ^ name type-           | TyConEntry (Maybe Mod) String String -- ^ type flavour+data Entry = IdEntry (Maybe Exported) String String -- ^ name type+           | ConEntry (Maybe Exported) String String -- ^ name type+           | PatSynEntry (Maybe Exported) String String -- ^ name orig+           | TyConEntry (Maybe Exported) String String -- ^ type flavour  data ModuleEntries = ModuleEntries GHC.ModuleName [Entry] @@ -171,15 +179,26 @@ -- of their dependencies and local projects. type Haddocks = [FilePath] -data PackageEntries = PackageEntries GHC.UnitId [ModuleEntries] Haddocks+-- Bool indicates if this is an -inplace package+data PackageEntries = PackageEntries SourcePackageId Bool [ModuleEntries] Haddocks -newtype Mod = Mod GHC.Module+-- srcid is Nothing if it matches the re-export location+data Exported = Exported (Maybe SourcePackageId) GHC.ModuleName -instance ToSexp Mod where-  toSexp (Mod m) = alist-    [ ("unitid", SexpString . normaliseUnitId . moduleUnitId $ m),-      ("module", SexpString . moduleNameString . moduleName $ m) ]+mkExported :: GHC.DynFlags -> UnitId -> Module -> Exported+mkExported dflags unitid m =+  let unitid' = moduleUnitId m+   in Exported+        (if unitid == unitid'+           then Nothing+           else Just . sourcePackageId $ getPackageDetails dflags unitid')+        (moduleName m) +instance ToSexp Exported where+  toSexp (Exported srcid name) = alist+    [ ("srcid", toSexp $ unpackFS . coerce <$> srcid),+      ("module", SexpString . moduleNameString $ name) ]+ instance ToSexp Entry where   toSexp (IdEntry m name typ) = alist     [ ("name", SexpString name),@@ -191,6 +210,11 @@       ("type", SexpString typ),       ("class", "con"),       ("export", toSexp m) ]+  toSexp (PatSynEntry m name typ) = alist+    [ ("name", SexpString name),+      ("type", SexpString typ),+      ("class", "pat"),+      ("export", toSexp m) ]   toSexp (TyConEntry m typ flavour) = alist     [ ("type", SexpString typ),       ("class", "tycon"),@@ -205,8 +229,10 @@       ]  instance ToSexp PackageEntries where-  toSexp (PackageEntries unitid modules haddocks) =+  toSexp (PackageEntries srcid inplace modules haddocks) =     alist-      [ ("unitid", SexpString . normaliseUnitId $ unitid),+      [ ("srcid", toSexp . unpackFS . coerce $ srcid),+        ("inplace", toSexp inplace),         ("modules", toSexp modules),         ("haddocks", toSexp haddocks) ]+

@@ -6,11 +6,10 @@ import HsInspect.Sexp import Json import MonadUtils (mapSndM)-import Outputable (defaultUserStyle, initSDocContext, runSDoc)+import Outputable (showSDoc)  encodeJson :: GHC.DynFlags -> JsonDoc -> String-encodeJson dflags j = show . flip runSDoc ctx . renderJSON $ j-  where ctx = initSDocContext dflags $ defaultUserStyle dflags+encodeJson dflags j = showSDoc dflags . renderJSON $ j  sexpToJson :: Sexp -> Either String JsonDoc sexpToJson SexpNil = Right JSNull

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,6 +7,7 @@  import Control.Monad (join, void) import Control.Monad.IO.Class (liftIO)+import Data.Coerce import Data.List (delete, nub, sort, (\\)) import Data.Maybe (catMaybes) import qualified Data.Set as Set@@ -18,7 +20,8 @@ import HsInspect.Util import HsInspect.Workarounds import Module (Module(..), ModuleName)-import Packages (PackageState(..))+import qualified PackageConfig as GHC+import Packages (PackageState(..), getPackageDetails) import qualified RdrName as GHC  -- Similar to packunused / weeder, but more reliable (and doesn't require a@@ -36,7 +39,8 @@   let home = GHC.thisPackage dflags       used = delete home . nub . sort $ pkgs       loaded = nub . sort . explicitPackages $ GHC.pkgState dflags-  pure $ PkgSummary used (loaded \\ used)+      asNames unitids = GHC.packageName . getPackageDetails dflags <$> unitids+  pure $ PkgSummary (asNames used) (asNames $ loaded \\ used)  findPackage :: GHC.GhcMonad m => ModuleName -> Maybe FastString -> m (Maybe GHC.UnitId) findPackage m mp = do@@ -57,11 +61,11 @@ qModule :: GHC.ImportSpec -> (ModuleName, Maybe FastString) qModule (GHC.ImpSpec (GHC.ImpDeclSpec{GHC.is_mod}) _) = (is_mod, Nothing) -data PkgSummary = PkgSummary [GHC.UnitId] [GHC.UnitId]+data PkgSummary = PkgSummary [GHC.PackageName] [GHC.PackageName]   deriving (Eq, Ord)  instance ToSexp PkgSummary where   toSexp (PkgSummary used unused) =     alist [ ("used", toS used)           , ("unused", toS unused) ]-    where toS ids = toSexp $ normaliseUnitId <$> ids+    where toS ids = toSexp $ unpackFS . coerce <$> ids

@@ -46,6 +46,10 @@ instance ToSexp String where   toSexp s = SexpString s +instance ToSexp Bool where+  toSexp False = SexpNil+  toSexp True = SexpSymbol "t"+ instance ToSexp a => ToSexp [a] where   toSexp as = list $ toSexp <$> as 

@@ -3,25 +3,12 @@  module HsInspect.Util where -import Data.List (intercalate) import Data.List (isSuffixOf) import Data.Maybe (catMaybes) import Data.Set (Set) import qualified Data.Set as Set import qualified GHC as GHC-import qualified Module as GHC import System.Directory (doesDirectoryExist, listDirectory)---- removes the cabal nix-style hashcode-normaliseUnitId :: GHC.UnitId -> String-normaliseUnitId (GHC.unitIdString -> unitid) =-  case reverse $ split ('-' ==) unitid of-    "inplace" : _ -> unitid-    _ : version : pkg ->-      if any ('.' ==) version-        then intercalate "-" (pkg <> [version])-        else unitid -- versioned but without a hashcode-    _ -> unitid -- unversioned, e.g. base  getTargetModules :: GHC.GhcMonad m => m (Set GHC.ModuleName) getTargetModules = do