{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module HsInspect.Packages (packages, PkgSummary) where
import Control.Monad (join, void)
import Control.Monad.IO.Class (liftIO)
import Data.Coerce
import Data.List (delete, nub, sort, (\\))
import Data.Maybe (catMaybes, mapMaybe)
import qualified Data.Set as Set
import qualified DynFlags as GHC
import FastString
import Finder (findImportedModule)
import qualified GHC
import HscTypes (FindResult(..))
import HsInspect.Sexp
import HsInspect.Util
import HsInspect.Workarounds
import Module (Module(..), ModuleName)
import qualified PackageConfig as GHC
import Packages (PackageState(..), lookupPackage)
import qualified RdrName as GHC
packages :: GHC.GhcMonad m => m PkgSummary
packages = do
mods <- Set.toList <$> getTargetModules
dflags <- GHC.getSessionDynFlags
void $ GHC.setSessionDynFlags dflags { GHC.ghcMode = GHC.CompManager }
_ <- GHC.load $ GHC.LoadAllTargets
imps <- nub . join <$> traverse getImports mods
pkgs <- catMaybes <$> traverse (uncurry findPackage) imps
let home = GHC.thisPackage dflags
used = delete home . nub . sort $ pkgs
loaded = nub . sort . explicitPackages $ GHC.pkgState dflags
asNames unitids = GHC.packageName <$> mapMaybe (lookupPackage dflags) unitids
pure $ PkgSummary (asNames used) (asNames $ loaded \\ used)
findPackage :: GHC.GhcMonad m => ModuleName -> Maybe FastString -> m (Maybe GHC.UnitId)
findPackage m mp = do
env <- GHC.getSession
res <- liftIO $ findImportedModule env m mp
pure $ case res of
Found _ (Module u _) -> Just $ u
_ -> Nothing
getImports :: GHC.GhcMonad m => ModuleName -> m [(ModuleName, Maybe FastString)]
getImports m = do
rdr_env <- minf_rdr_env' m
let imports = GHC.gre_imp =<< GHC.globalRdrEnvElts rdr_env
pure $ qModule <$> imports
qModule :: GHC.ImportSpec -> (ModuleName, Maybe FastString)
qModule (GHC.ImpSpec (GHC.ImpDeclSpec{GHC.is_mod}) _) = (is_mod, Nothing)
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 $ unpackFS . coerce <$> ids