hsinspect 0.0.7 → 0.0.8

raw patch · 9 files changed

+302/−204 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• exe/Main.hs +25/−27
• hsinspect.cabal +4/−3
• library/HsInspect/Imports.hs +8/−32
• library/HsInspect/Index.hs +158/−85
• library/HsInspect/Json.hs +21/−0
• library/HsInspect/Packages.hs +18/−49
• library/HsInspect/Sexp.hs +15/−7
• library/HsInspect/Util.hs +41/−0
• library/HsInspect/Workarounds.hs +12/−1

@@ -1,22 +1,21 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-}- module Main where +import qualified Config as GHC import Control.Monad import Control.Monad.IO.Class import Data.Char (isUpper) import Data.List (find, isPrefixOf) import DynFlags (parseDynamicFlagsCmdLine, updOptLevel)+import qualified EnumSet as EnumSet import qualified GHC as GHC import HsInspect.Imports import HsInspect.Index+import HsInspect.Json import HsInspect.Packages import HsInspect.Sexp as S-import Json-import Outputable (defaultUserStyle, initSDocContext, runSDoc) import System.Environment (getArgs) import System.Exit @@ -29,7 +28,7 @@  help :: String help =-  "hsinspect command ARGS [--json|help|version] -- [ghcflags]\n\n" +++  "hsinspect command ARGS [--json|help|version|ghc-version] -- [ghcflags]\n\n" ++   "  `command ARGS' can be:\n\n" ++   "  imports /path/to/file.hs - list the qualified imports for the file\n" ++   "                             along with their locally qualified (and\n" ++@@ -48,25 +47,29 @@     (putStrLn help) >> exitWith ExitSuccess   when (elem "--version" args) $     (putStrLn version) >> exitWith ExitSuccess+  when (elem "--ghc-version" args) $+    (putStrLn GHC.cProjectVersion) >> exitWith ExitSuccess   let libdir = (drop 2) <$> find ("-B" `isPrefixOf`) flags+      flags' = filter (not . ("-B" `isPrefixOf`)) flags   GHC.runGhc libdir $ do     dflags <- GHC.getSessionDynFlags     (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> ghcargs, _) <--      liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags)+      liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags')     void $ GHC.setSessionDynFlags dflags'            { GHC.hscTarget = GHC.HscInterpreted -- HscNothing compiles home modules, dunno why            , GHC.ghcLink   = GHC.LinkInMemory   -- required by HscInterpreted            , GHC.ghcMode   = GHC.MkDepend       -- prefer .hi to .hs for dependencies+           , GHC.warningFlags = EnumSet.empty+           , GHC.fatalWarningFlags = EnumSet.empty            }-    let homeModules = (filter (isUpper . head) ghcargs)-    GHC.setTargets $-      -- TODO it would be good if ghc had a "binary only" option for Targets-      --      with fail fast if only source code (no .hi) is discovered.-      (\m -> GHC.Target (GHC.TargetModule $ GHC.mkModuleName m) True Nothing) <$> homeModules-    let respond rest as = liftIO . putStrLn $+    let mkTarget m = GHC.Target (GHC.TargetModule $ GHC.mkModuleName m) True Nothing+    GHC.setTargets $ mkTarget <$> filter (isUpper . head) ghcargs+    let respond rest (S.filterNil . S.toSexp -> a) = liftIO . putStrLn $           if (elem "--json" rest)-          then encodeJson dflags' as-          else S.encode as+          then case sexpToJson a of+            Left err -> error err+            Right j -> encodeJson dflags' j+          else S.render a     case args of       "imports" : file : rest -> do         quals <- imports file@@ -74,21 +77,16 @@       "index" : rest -> do         hits <- index         respond rest hits-      "packages" : dir : rest -> do-        hits <- packages dir+      "packages" : rest -> do+        hits <- packages         respond rest hits       _ ->         liftIO $ error "invalid parameters" --- TODO let each component remove things that interfere+-- removes the "+RTS ... -RTS" sections filterFlags :: [String] -> [String]-filterFlags ("--" : rest) = filter allow rest-  where allow flag = "-Wno" `isPrefixOf` flag || not ("-W" `isPrefixOf` flag)-filterFlags _ = []--encodeJson :: ToJson a => GHC.DynFlags -> a -> String-encodeJson dflags as = show . flip runSDoc ctx . renderJSON . json $ as-  where ctx = initSDocContext dflags $ defaultUserStyle dflags--instance ToJson a => ToJson [a] where-  json as = JSArray $ json <$> as+filterFlags args = case span ("+RTS" /=) args of+  (front, []) -> front+  (front, _ : middle) -> case span ("-RTS" /=) middle of+    (_, []) -> front -- bad input?+    (_, _ : back) -> front <> back

@@ -1,6 +1,6 @@ cabal-version: 2.2 name:          hsinspect-version:       0.0.7+version:       0.0.8 synopsis:      Inspect Haskell source files. license:       GPL-3.0-or-later license-file:  LICENSE@@ -8,7 +8,7 @@ maintainer:    Tseen She copyright:     2019 Tseen She bug-reports:   https://gitlab.com/tseenshe/hsinspect/merge_requests-tested-with:   GHC ^>=8.4.4 || ^>=8.6.5+tested-with:   GHC ^>=8.4.4 || ^>=8.6.5 || ^>=8.8.1 category:      Building description:   Inspect @.hs@ files using the ghc api. @@ -44,7 +44,7 @@   hs-source-dirs: exe   build-depends:  hsinspect   main-is:        Main.hs-  ghc-options:    -threaded+  ghc-options:    -rtsopts -threaded -with-rtsopts=-N8  library   import:          deps@@ -54,6 +54,7 @@   exposed-modules:     HsInspect.Imports     HsInspect.Index+    HsInspect.Json     HsInspect.Packages     HsInspect.Sexp     HsInspect.Util

@@ -11,37 +11,28 @@ import Data.Maybe (fromJust) import DynFlags (unsafeGlobalDynFlags) import qualified GHC as GHC+import HscTypes (TargetId(..)) import HsInspect.Sexp import HsInspect.Workarounds-import HscTypes (TargetId (..))-import Json import Outputable (Outputable, showPpr)-import RdrName-  ( GlobalRdrElt (..),-    ImpDeclSpec (..),-    ImportSpec (..),-    globalRdrEnvElts,-  )+import RdrName (GlobalRdrElt(..), ImpDeclSpec(..), ImportSpec(..),+                globalRdrEnvElts)  imports :: GHC.GhcMonad m => FilePath -> m [Qualified] imports file = do-  gres <- imports' file-  pure $ describe =<< gres--imports' :: GHC.GhcMonad m => FilePath -> m [GlobalRdrElt]-imports' file = do-  -- TODO no need for this in 8.8.2+   (fromJust -> m, target) <- importsOnly mempty file    GHC.removeTarget $ TargetModule m   GHC.addTarget target -  -- TODO performance can be very bad here. It is possible that ghc is compiling-  -- modules in the home module that have .hi files that would be much faster.+  -- performance can be very bad here if the user hasn't compiled recently. We+  -- could do the Index hack and only load things that have .hi files but that+  -- will result in very bizarre behaviour and we don't expect the user's code+  -- to be compilable at this point.   _ <- GHC.load $ GHC.LoadUpTo m    rdr_env <- minf_rdr_env' m-  pure $ globalRdrEnvElts rdr_env+  pure $ describe =<< globalRdrEnvElts rdr_env  showGhc :: (Outputable a) => a -> String showGhc = showPpr unsafeGlobalDynFlags@@ -61,10 +52,6 @@           fqn = showGhc is_mod ++ "." ++ showGhc gre_name        in Qualified ln lqn fqn --- Note that `nameSrcLoc gre_name` is empty--- 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@@ -82,14 +69,3 @@         ("qual", toSexp lqn),         ("full", toSexp fqn)       ]--instance ToJson Qualified where-  json (Qualified ln lqn fqn) =-    JSObject-      [ ("local", json' ln),-        ("qual", json' lqn),-        ("full", JSString fqn)-      ]-    where-      json' Nothing = JSNull-      json' (Just a) = JSString a

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}  -- | Dumps an index of all terms and their types@@ -9,99 +10,192 @@   ) where -import Avail (AvailInfo (..))-import BinIface-  ( CheckHiWay (..),-    TraceBinIFaceReading (..),-    readBinIface,-  )+import Avail (AvailInfo(..))+import BinIface (CheckHiWay(..), TraceBinIFaceReading(..), readBinIface)+import qualified ConLike as GHC import Control.Monad import Control.Monad.IO.Class-import Data.List (isSuffixOf)-import Data.Maybe (catMaybes, maybeToList)+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 qualified GHC import GHC.PackageDb+import qualified GHC.PackageDb as GHC+import HscTypes (ModIface(..))+import HsInspect.Json () import HsInspect.Sexp import HsInspect.Util-import HscTypes (ModIface (..)) import qualified Id as GHC-import Json-import Module (Module (..), moduleNameString, unitIdString)+import Module (Module(..), moduleNameString)+import qualified Name as GHC import Outputable (showPpr)+import qualified Outputable as GHC import PackageConfig---import System.IO (hPutStrLn, stderr)-import PackageConfig (packageConfigId)+import qualified PackageConfig as GHC import Packages (explicitPackages, lookupPackage)+--import System.IO (hPutStrLn, stderr) import TcEnv (tcLookup) import TcRnMonad (initTcInteractive) import qualified TcRnTypes as GHC+import qualified TyCon 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+  deps <- traverse getPkgSymbols 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+  loadCompiledModules+  let unitid = GHC.thisPackage dflags+      dirs = maybeToList $ GHC.hiDir dflags+  home_mods <- getTargetModules+  home_entries <- getSymbols unitid [] home_mods dirs -hiToSymbols :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe ModuleEntries)-hiToSymbols exposed hi = do-  env <- GHC.getSession+  pure $ home_entries : deps++-- finds the module names of all the .hi files in the output directory and then+-- tells ghc to load them as the only targets. Compared to loading all the home+-- modules provided by the ghcflags, this means that ghc can only see the+-- contents of compiled files and will not attempt to compile any source code.+-- Obviously comes with caveats but will be much faster if the preferred+-- behaviour is to fail fast with partial data instead of trying (futilely) to+-- compile all home modules with the interactive compiler.+loadCompiledModules :: GHC.GhcMonad m => m ()+loadCompiledModules = do   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)+  case GHC.hiDir dflags of+    Nothing -> pure ()+    Just dir -> do+      compiled <- getCompiledTargets dir+      GHC.setTargets compiled+      void . GHC.load $ GHC.LoadAllTargets -          things <- join <$> traverse thing (mi_exports iface)+getCompiledTargets :: GHC.GhcMonad m => FilePath -> m [GHC.Target]+getCompiledTargets dir = do+  provided <- getTargetModules+  his <- liftIO $ walkSuffix ".hi" dir+  modules <- catMaybes <$> traverse (flip withHi (pure . mi_module)) his+  let toTarget m =+        if Set.member m provided+          then Just $ GHC.Target (GHC.TargetModule m) True Nothing+          else Nothing+  pure $ mapMaybe (toTarget . moduleName) modules -          -- 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+-- Perform an operation given the parsed .hi file. tcLookup will only succeed if+-- the module is on the packagedb or is a home module that has been loaded.+withHi :: GHC.GhcMonad m => FilePath -> (GHC.ModIface -> (GHC.TcRnIf GHC.TcGblEnv GHC.TcLclEnv) a) -> m (Maybe a)+withHi hi f = do+  env <- GHC.getSession+  (_, res) <- liftIO . initTcInteractive env $ do+    iface <- readBinIface IgnoreHiWay QuietBinIFaceReading hi+    f iface+  pure res -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+getPkgSymbols :: GHC.GhcMonad m => PackageConfig -> m PackageEntries+getPkgSymbols pkg =+  let unitid = GHC.packageConfigId pkg+      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 --- 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+getSymbols :: GHC.GhcMonad m => GHC.UnitId -> [FilePath] -> Set GHC.ModuleName -> [FilePath] -> m PackageEntries+getSymbols unitid haddocks exposed dirs = do+  let findHis dir = liftIO $ walkSuffix ".hi" dir+  his <- join <$> traverse findHis dirs+  dflags <- GHC.getSessionDynFlags+  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 +-- 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.+hiToSymbols+  :: GHC.GhcMonad m+  => Set GHC.ModuleName+  -> FilePath+  -> m (Maybe (GHC.Module, [(Maybe GHC.Module, GHC.TcTyThing)]))+hiToSymbols exposed hi = (join <$>) <$> withHi hi $ \iface -> do+  let m = mi_module iface+  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 _ members _) = traverse tcLookup' members+          reexport name = do+            modl <- GHC.nameModule_maybe name+            if m == modl then Nothing else Just modl+          tcLookup' name = (reexport name,) <$> tcLookup name+      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) =+  let+    shw :: GHC.Outputable m => m -> String+    shw = showPpr dflags+   in case thing of+    (GHC.AnId var) -> Just $ IdEntry m+      (shw $ GHC.idName var)+      (shw $ GHC.idType var) -- TODO fully qualify+    (GHC.AConLike (GHC.RealDataCon dc)) -> Just $ ConEntry m+      (shw $ GHC.getName dc)+      (shw $ GHC.dataConUserType dc) -- TODO fully qualify+    -- TODO PatSynCon+    (GHC.ATyCon tc) -> Just $ TyConEntry m+      (shw $ GHC.tyConName tc)+      (shw $ GHC.tyConFlavour tc)+    _ -> 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 ModuleEntries = ModuleEntries GHC.ModuleName [Entry] -data PackageEntries = PackageEntries GHC.UnitId [ModuleEntries]+-- The haddocks serve a dual purpose: not only do they point to where haddocks+-- might be, they give a hint to the text editor where the sources for this+-- package are (e.g. with the ghc distribution, build tool store or local).+--+-- Users should type `cabal haddock --enable-documentation` to populate the docs+-- of their dependencies and local projects.+type Haddocks = [FilePath] +data PackageEntries = PackageEntries GHC.UnitId [ModuleEntries] Haddocks++newtype Mod = Mod GHC.Module++instance ToSexp Mod where+  toSexp (Mod m) = alist+    [ ("unitid", SexpString . normaliseUnitId . moduleUnitId $ m),+      ("module", SexpString . moduleNameString . moduleName $ m) ]+ instance ToSexp Entry where-  toSexp (Entry term typ) =-    alist-      [ ("name", SexpString term),-        ("type", SexpString typ)-      ]+  toSexp (IdEntry m name typ) = alist+    [ ("name", SexpString name),+      ("type", SexpString typ),+      ("class", "id"),+      ("export", toSexp m)]+  toSexp (ConEntry m name typ) = alist+    [ ("name", SexpString name),+      ("type", SexpString typ),+      ("class", "con"),+      ("export", toSexp m) ]+  toSexp (TyConEntry m typ flavour) = alist+    [ ("type", SexpString typ),+      ("class", "tycon"),+      ("flavour", SexpString flavour),+      ("export", toSexp m) ]  instance ToSexp ModuleEntries where   toSexp (ModuleEntries modl entries) =@@ -111,29 +205,8 @@       ]  instance ToSexp PackageEntries where-  toSexp (PackageEntries pkg modules) =+  toSexp (PackageEntries unitid modules haddocks) =     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)-      ]+      [ ("unitid", SexpString . normaliseUnitId $ unitid),+        ("modules", toSexp modules),+        ("haddocks", toSexp haddocks) ]

@@ -0,0 +1,21 @@+{-# LANGUAGE ViewPatterns #-}++module HsInspect.Json where++import qualified GHC as GHC+import HsInspect.Sexp+import Json+import MonadUtils (mapSndM)+import Outputable (defaultUserStyle, initSDocContext, runSDoc)++encodeJson :: GHC.DynFlags -> JsonDoc -> String+encodeJson dflags j = show . flip runSDoc ctx . renderJSON $ j+  where ctx = initSDocContext dflags $ defaultUserStyle dflags++sexpToJson :: Sexp -> Either String JsonDoc+sexpToJson SexpNil = Right JSNull+sexpToJson (toAList -> Just kvs) = JSObject <$> mapSndM sexpToJson kvs+sexpToJson (toList -> Just as) = JSArray <$> traverse sexpToJson as+sexpToJson (SexpCons _ _) = Left $ "cons cell has no JSON equivalent"+sexpToJson (SexpString s) = Right $ JSString s+sexpToJson (SexpSymbol s) = Right $ JSString s -- nobody said it had to roundtrip

@@ -1,16 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}  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.List (delete, nub, sort, (\\)) import Data.Maybe (catMaybes) import qualified Data.Set as Set+import qualified DynFlags as GHC import FastString import Finder (findImportedModule) import qualified GHC@@ -18,28 +17,15 @@ import HsInspect.Sexp import HsInspect.Util import HsInspect.Workarounds-import Json-import Module (Module(..), ModuleName, moduleNameString, unitIdString)+import Module (Module(..), ModuleName) import Packages (PackageState(..))+import qualified RdrName as GHC  -- Similar to packunused / weeder, but more reliable (and doesn't require a -- separate -ddump-minimal-imports pass).------ 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-  -- module, but with a twist: we only parse the imports from external packages.-  -- To do this we have to unload the home modules as provided by parameters and-  -- filter then when parsing the imports section.-  args <- GHC.getTargets-  let homes = Set.fromList . catMaybes $ getModule <$> args--  srcs <- liftIO $ (filter (".hs" `isSuffixOf`)) <$> walk dir--  -- mods == homes. We could do two passes (ignore provided targets)-  (catMaybes -> mods, targets) <- unzip <$> traverse (importsOnly homes) srcs-  _ <- GHC.setTargets targets+packages :: GHC.GhcMonad m => m PkgSummary+packages = do+  mods <- Set.toList <$> getTargetModules    dflags <- GHC.getSessionDynFlags   void $ GHC.setSessionDynFlags dflags { GHC.ghcMode = GHC.CompManager }@@ -47,15 +33,11 @@    imps <- nub . join <$> traverse getImports mods   pkgs <- catMaybes <$> traverse (uncurry findPackage) imps-  let used = nub . sort $ pkgs-  let loaded = nub . sort . explicitPackages $ GHC.pkgState dflags+  let home = GHC.thisPackage dflags+      used = delete home . nub . sort $ pkgs+      loaded = nub . sort . explicitPackages $ GHC.pkgState dflags   pure $ PkgSummary used (loaded \\ used) -getModule :: GHC.Target -> Maybe ModuleName-getModule GHC.Target{GHC.targetId} = case targetId of-  GHC.TargetModule m -> Just m-  GHC.TargetFile _ _ -> Nothing- findPackage :: GHC.GhcMonad m => ModuleName -> Maybe FastString -> m (Maybe GHC.UnitId) findPackage m mp = do   env <- GHC.getSession@@ -66,21 +48,14 @@  getImports :: GHC.GhcMonad m => ModuleName -> m [(ModuleName, Maybe FastString)] getImports m = do-  modSum <- GHC.getModSummary m-  pmod <- GHC.parseModule modSum-  tmod <- GHC.typecheckModule pmod-  case GHC.tm_renamed_source tmod of-    Nothing -> error $ "bad module: " ++ moduleNameString m-    Just (_, (GHC.unLoc <$>) -> imports, _, _) ->-      pure . catMaybes $ qModule <$> imports+  rdr_env <- minf_rdr_env' m+  let imports = GHC.gre_imp =<< GHC.globalRdrEnvElts rdr_env+  pure $ qModule <$> imports -qModule :: GHC.ImportDecl p -> Maybe (ModuleName, Maybe FastString)-qModule GHC.ImportDecl{GHC.ideclName, GHC.ideclPkgQual} = Just $-  (GHC.unLoc ideclName, qual)-  where qual = sl_fs <$> ideclPkgQual-#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)-qModule (GHC.XImportDecl _) = Nothing-#endif+-- PackageImports are not supported until ImpDeclSpec supports them (could parse+-- gre_name's src span if we're desperate)+qModule :: GHC.ImportSpec -> (ModuleName, Maybe FastString)+qModule (GHC.ImpSpec (GHC.ImpDeclSpec{GHC.is_mod}) _) = (is_mod, Nothing)  data PkgSummary = PkgSummary [GHC.UnitId] [GHC.UnitId]   deriving (Eq, Ord)@@ -89,10 +64,4 @@   toSexp (PkgSummary used unused) =     alist [ ("used", toS used)           , ("unused", toS unused) ]-    where toS ids = toSexp $ unitIdString <$> ids--instance ToJson PkgSummary where-  json (PkgSummary used unused) =-    JSObject [ ("used", toJ used)-             , ("unused", toJ unused) ]-    where toJ ids = JSArray $ JSString . unitIdString <$> ids+    where toS ids = toSexp $ normaliseUnitId <$> ids

@@ -3,6 +3,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} +-- | Very minimal ADT for outputting some S-Expressions. module HsInspect.Sexp where  import Data.List (intercalate)@@ -31,14 +32,17 @@   where     mkEl (k, v) = [SexpCons k v] -attrs :: [(String, Sexp)] -> Sexp-attrs els = list $ mkEl =<< els-  where-    mkEl (k, v) = [SexpSymbol k, v]+toAList :: Sexp -> Maybe [(String, Sexp)]+toAList SexpNil = Just []+toAList (SexpCons (SexpCons (SexpSymbol k) v) rest) = ((k, v) :) <$> toAList rest+toAList _ = Nothing  class ToSexp a where   toSexp :: a -> Sexp +instance ToSexp Sexp where+  toSexp = id+ instance ToSexp String where   toSexp s = SexpString s @@ -49,12 +53,16 @@   toSexp (Just a) = toSexp a   toSexp Nothing = SexpNil +filterNil :: Sexp -> Sexp+filterNil SexpNil = SexpNil+filterNil (SexpCons (SexpCons (SexpSymbol _) SexpNil) rest) = filterNil rest+filterNil (SexpCons car cdr) = (SexpCons (filterNil car) (filterNil cdr))+filterNil (SexpString s) = SexpString s+filterNil (SexpSymbol s) = SexpSymbol s+ render :: Sexp -> String render SexpNil = "nil" render (toList -> Just ss) = "(" ++ (intercalate " " $ render <$> ss) ++ ")\n" render (SexpCons a b) = "(" ++ render a ++ " . " ++ render b ++ ")\n" render (SexpString s) = "\"" ++ escapeJsonString s ++ "\"" render (SexpSymbol a) = escapeJsonString a--encode :: ToSexp a => a -> String-encode = render . toSexp

@@ -1,7 +1,41 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}+ 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+  args <- GHC.getTargets+  pure . Set.fromList . catMaybes $ getModule <$> args+  where+    getModule :: GHC.Target -> Maybe GHC.ModuleName+    getModule GHC.Target{GHC.targetId} = case targetId of+      GHC.TargetModule m -> Just m+      GHC.TargetFile _ _ -> Nothing++walkSuffix :: String -> FilePath -> IO [FilePath]+walkSuffix suffix dir = filter (suffix `isSuffixOf`) <$> walk dir+ walk :: FilePath -> IO [FilePath] walk dir = do   isDir <- doesDirectoryExist dir@@ -24,3 +58,10 @@         else do           xs' <- xs           pure $ x' ++ xs'++-- from extra+split :: (a -> Bool) -> [a] -> [[a]]+split _ [] = [[]]+split f (x : xs) | f x = [] : split f xs+                 | y : ys <- split f xs = (x : y) : ys+                 | otherwise = [[]] -- never happens

@@ -26,11 +26,22 @@ import System.Directory (getModificationTime, removeFile) import TcRnTypes (tcg_rdr_env) +-- TODO avoid this codepath in 8.8.2+ -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/merge_requests/1541 importsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> FilePath -> m (Maybe GHC.ModuleName, Target) importsOnly homes file = do   sess <- GHC.getSession+  -- NOTE: the behaviour of preprocess changed in 8.8.1 and it no longer reads+  -- and sets LANGUAGE pragamas from in header of the file. Since this function+  -- is no longer needed in 8.8.2 we don't bother fixing this.+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)+  pp <- liftIO $ preprocess sess file Nothing Nothing+  let (dflags, tmp) = case pp of+        Left _ -> error $ "preprocessing failed " <> show file+        Right success -> success+#else   (dflags, tmp) <- liftIO $ preprocess sess (file, Nothing)+#endif   full <- liftIO $ hGetStringBuffer tmp   when (".hscpp" `isSuffixOf` tmp) $     liftIO . removeFile $ tmp@@ -46,7 +57,7 @@       let modname = unLoc <$> GHC.hsmodName hsmod           extra =             if modname == Nothing || modname == (Just $ GHC.mkModuleName "Main")-            then "\nmain = return ()" -- TODO check that return is imported+            then "\nmain = return ()"             else ""           imps = filter allowed $ GHC.hsmodImports hsmod           -- WORKAROUND https://gitlab.haskell.org/ghc/ghc/issues/17066