{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module HsInspect.Packages (packages, PkgSummary) where

import Control.Monad (join, void)
import Control.Monad.IO.Class (liftIO)
import Data.List (delete, nub, nubBy, sort, (\\))
import Data.Maybe (catMaybes, mapMaybe)
import Data.Set (Set)
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

-- Similar to packunused / weeder, but more reliable (and doesn't require a
-- separate -ddump-minimal-imports pass).
packages :: GHC.GhcMonad m => m PkgSummary
packages :: m PkgSummary
packages = do
  Set ModuleName
homes <- m (Set ModuleName)
forall (m :: * -> *). GhcMonad m => m (Set ModuleName)
getTargetModules
  Set ModuleName -> m ()
forall (m :: * -> *). GhcMonad m => Set ModuleName -> m ()
targetsImportsOnly Set ModuleName
homes

  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  m [InstalledUnitId] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ()) -> m [InstalledUnitId] -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags { ghcMode :: GhcMode
GHC.ghcMode = GhcMode
GHC.CompManager }
  SuccessFlag
_ <- LoadHowMuch -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load (LoadHowMuch -> m SuccessFlag) -> LoadHowMuch -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ LoadHowMuch
GHC.LoadAllTargets

  [(ModuleName, Maybe FastString)]
imps <- [(ModuleName, Maybe FastString)]
-> [(ModuleName, Maybe FastString)]
forall a. Eq a => [a] -> [a]
nub ([(ModuleName, Maybe FastString)]
 -> [(ModuleName, Maybe FastString)])
-> ([[(ModuleName, Maybe FastString)]]
    -> [(ModuleName, Maybe FastString)])
-> [[(ModuleName, Maybe FastString)]]
-> [(ModuleName, Maybe FastString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(ModuleName, Maybe FastString)]]
-> [(ModuleName, Maybe FastString)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[(ModuleName, Maybe FastString)]]
 -> [(ModuleName, Maybe FastString)])
-> m [[(ModuleName, Maybe FastString)]]
-> m [(ModuleName, Maybe FastString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModuleName -> m [(ModuleName, Maybe FastString)])
-> [ModuleName] -> m [[(ModuleName, Maybe FastString)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ModuleName -> m [(ModuleName, Maybe FastString)]
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> m [(ModuleName, Maybe FastString)]
getImports (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
homes)
  [UnitId]
pkgs <- [Maybe UnitId] -> [UnitId]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UnitId] -> [UnitId]) -> m [Maybe UnitId] -> m [UnitId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ModuleName, Maybe FastString) -> m (Maybe UnitId))
-> [(ModuleName, Maybe FastString)] -> m [Maybe UnitId]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ModuleName -> Maybe FastString -> m (Maybe UnitId))
-> (ModuleName, Maybe FastString) -> m (Maybe UnitId)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ModuleName -> Maybe FastString -> m (Maybe UnitId)
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m (Maybe UnitId)
findPackage) [(ModuleName, Maybe FastString)]
imps
  let home :: UnitId
home = DynFlags -> UnitId
GHC.thisPackage DynFlags
dflags
      used :: [UnitId]
used = UnitId -> [UnitId] -> [UnitId]
forall a. Eq a => a -> [a] -> [a]
delete UnitId
home ([UnitId] -> [UnitId])
-> ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a]
nub ([UnitId] -> [UnitId])
-> ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
sort ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ [UnitId]
pkgs
      loaded :: [UnitId]
loaded = [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a]
nub ([UnitId] -> [UnitId])
-> (PackageState -> [UnitId]) -> PackageState -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
sort ([UnitId] -> [UnitId])
-> (PackageState -> [UnitId]) -> PackageState -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageState -> [UnitId]
explicitPackages (PackageState -> [UnitId]) -> PackageState -> [UnitId]
forall a b. (a -> b) -> a -> b
$ DynFlags -> PackageState
GHC.pkgState DynFlags
dflags
      asNames :: [UnitId] -> [PackageName]
asNames [UnitId]
unitids = InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> PackageName
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> srcpkgname
GHC.packageName (InstalledPackageInfo
   ComponentId
   SourcePackageId
   PackageName
   InstalledUnitId
   UnitId
   ModuleName
   Module
 -> PackageName)
-> [InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      UnitId
      ModuleName
      Module]
-> [PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnitId
 -> Maybe
      (InstalledPackageInfo
         ComponentId
         SourcePackageId
         PackageName
         InstalledUnitId
         UnitId
         ModuleName
         Module))
-> [UnitId]
-> [InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      UnitId
      ModuleName
      Module]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DynFlags
-> UnitId
-> Maybe
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
lookupPackage DynFlags
dflags) [UnitId]
unitids
  PkgSummary -> m PkgSummary
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PkgSummary -> m PkgSummary) -> PkgSummary -> m PkgSummary
forall a b. (a -> b) -> a -> b
$ [PackageName] -> [PackageName] -> PkgSummary
PkgSummary ([UnitId] -> [PackageName]
asNames [UnitId]
used) ([UnitId] -> [PackageName]
asNames ([UnitId] -> [PackageName]) -> [UnitId] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ [UnitId]
loaded [UnitId] -> [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UnitId]
used)

targetsImportsOnly :: GHC.GhcMonad m => Set GHC.ModuleName -> m ()
targetsImportsOnly :: Set ModuleName -> m ()
targetsImportsOnly Set ModuleName
homes = do
  [FilePath]
files <- m [FilePath]
forall (m :: * -> *). GhcMonad m => m [FilePath]
homeSources
  [(Maybe ModuleName, Target)]
trimmed <- (FilePath -> m (Maybe ModuleName, Target))
-> [FilePath] -> m [(Maybe ModuleName, Target)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Set ModuleName -> FilePath -> m (Maybe ModuleName, Target)
forall (m :: * -> *).
GhcMonad m =>
Set ModuleName -> FilePath -> m (Maybe ModuleName, Target)
importsOnly Set ModuleName
homes) [FilePath]
files
  -- side effect: multiple modules with no name will be deduped
  let fstEq :: (a, b) -> (a, b) -> Bool
fstEq (a
n1, b
_) (a
n2, b
_) = a
n1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
n2
      targets :: [Target]
targets = ((Maybe ModuleName, Target) -> Target
forall a b. (a, b) -> b
snd ((Maybe ModuleName, Target) -> Target)
-> [(Maybe ModuleName, Target)] -> [Target]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([(Maybe ModuleName, Target)] -> [Target])
-> ([(Maybe ModuleName, Target)] -> [(Maybe ModuleName, Target)])
-> [(Maybe ModuleName, Target)]
-> [Target]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe ModuleName, Target) -> (Maybe ModuleName, Target) -> Bool)
-> [(Maybe ModuleName, Target)] -> [(Maybe ModuleName, Target)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Maybe ModuleName, Target) -> (Maybe ModuleName, Target) -> Bool
forall a b b. Eq a => (a, b) -> (a, b) -> Bool
fstEq ([(Maybe ModuleName, Target)] -> [Target])
-> [(Maybe ModuleName, Target)] -> [Target]
forall a b. (a -> b) -> a -> b
$ [(Maybe ModuleName, Target)]
trimmed
  [Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
targets

findPackage :: GHC.GhcMonad m => ModuleName -> Maybe FastString -> m (Maybe GHC.UnitId)
findPackage :: ModuleName -> Maybe FastString -> m (Maybe UnitId)
findPackage ModuleName
m Maybe FastString
mp = do
  HscEnv
env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  FindResult
res <- IO FindResult -> m FindResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> m FindResult) -> IO FindResult -> m FindResult
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
env ModuleName
m Maybe FastString
mp
  Maybe UnitId -> m (Maybe UnitId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UnitId -> m (Maybe UnitId))
-> Maybe UnitId -> m (Maybe UnitId)
forall a b. (a -> b) -> a -> b
$ case FindResult
res of
    Found ModLocation
_ (Module UnitId
u ModuleName
_) -> UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just (UnitId -> Maybe UnitId) -> UnitId -> Maybe UnitId
forall a b. (a -> b) -> a -> b
$ UnitId
u
    FindResult
_ -> Maybe UnitId
forall a. Maybe a
Nothing

getImports :: GHC.GhcMonad m => ModuleName -> m [(ModuleName, Maybe FastString)]
getImports :: ModuleName -> m [(ModuleName, Maybe FastString)]
getImports ModuleName
m = do
  GlobalRdrEnv
rdr_env <- ModuleName -> m GlobalRdrEnv
forall (m :: * -> *). GhcMonad m => ModuleName -> m GlobalRdrEnv
minf_rdr_env' ModuleName
m
  let imports :: [ImportSpec]
imports = GlobalRdrElt -> [ImportSpec]
GHC.gre_imp (GlobalRdrElt -> [ImportSpec]) -> [GlobalRdrElt] -> [ImportSpec]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GlobalRdrEnv -> [GlobalRdrElt]
GHC.globalRdrEnvElts GlobalRdrEnv
rdr_env
  [(ModuleName, Maybe FastString)]
-> m [(ModuleName, Maybe FastString)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(ModuleName, Maybe FastString)]
 -> m [(ModuleName, Maybe FastString)])
-> [(ModuleName, Maybe FastString)]
-> m [(ModuleName, Maybe FastString)]
forall a b. (a -> b) -> a -> b
$ ImportSpec -> (ModuleName, Maybe FastString)
qModule (ImportSpec -> (ModuleName, Maybe FastString))
-> [ImportSpec] -> [(ModuleName, Maybe FastString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ImportSpec]
imports

-- 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 :: ImportSpec -> (ModuleName, Maybe FastString)
qModule (GHC.ImpSpec (GHC.ImpDeclSpec{ModuleName
is_mod :: ImpDeclSpec -> ModuleName
is_mod :: ModuleName
GHC.is_mod}) ImpItemSpec
_) = (ModuleName
is_mod, Maybe FastString
forall a. Maybe a
Nothing)

data PkgSummary = PkgSummary [GHC.PackageName] [GHC.PackageName]
  deriving (PkgSummary -> PkgSummary -> Bool
(PkgSummary -> PkgSummary -> Bool)
-> (PkgSummary -> PkgSummary -> Bool) -> Eq PkgSummary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PkgSummary -> PkgSummary -> Bool
$c/= :: PkgSummary -> PkgSummary -> Bool
== :: PkgSummary -> PkgSummary -> Bool
$c== :: PkgSummary -> PkgSummary -> Bool
Eq, Eq PkgSummary
Eq PkgSummary
-> (PkgSummary -> PkgSummary -> Ordering)
-> (PkgSummary -> PkgSummary -> Bool)
-> (PkgSummary -> PkgSummary -> Bool)
-> (PkgSummary -> PkgSummary -> Bool)
-> (PkgSummary -> PkgSummary -> Bool)
-> (PkgSummary -> PkgSummary -> PkgSummary)
-> (PkgSummary -> PkgSummary -> PkgSummary)
-> Ord PkgSummary
PkgSummary -> PkgSummary -> Bool
PkgSummary -> PkgSummary -> Ordering
PkgSummary -> PkgSummary -> PkgSummary
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PkgSummary -> PkgSummary -> PkgSummary
$cmin :: PkgSummary -> PkgSummary -> PkgSummary
max :: PkgSummary -> PkgSummary -> PkgSummary
$cmax :: PkgSummary -> PkgSummary -> PkgSummary
>= :: PkgSummary -> PkgSummary -> Bool
$c>= :: PkgSummary -> PkgSummary -> Bool
> :: PkgSummary -> PkgSummary -> Bool
$c> :: PkgSummary -> PkgSummary -> Bool
<= :: PkgSummary -> PkgSummary -> Bool
$c<= :: PkgSummary -> PkgSummary -> Bool
< :: PkgSummary -> PkgSummary -> Bool
$c< :: PkgSummary -> PkgSummary -> Bool
compare :: PkgSummary -> PkgSummary -> Ordering
$ccompare :: PkgSummary -> PkgSummary -> Ordering
$cp1Ord :: Eq PkgSummary
Ord)

{- BOILERPLATE PkgSummary ToSexp field=[used,unused] -}
{- BOILERPLATE START -}
instance ToSexp PkgSummary where
  toSexp :: PkgSummary -> Sexp
toSexp (PkgSummary [PackageName]
p_1_1 [PackageName]
p_1_2) = [(Sexp, Sexp)] -> Sexp
alist [(Sexp
"used", [PackageName] -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp [PackageName]
p_1_1), (Sexp
"unused", [PackageName] -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp [PackageName]
p_1_2)]
{- BOILERPLATE END -}