-- |Description: Load dependencies for a project using @ghc-pkg@.
module Data.Prune.Dependency where

import Prelude hiding (unwords, words)

import Cabal.Config (cfgStoreDir, readConfig)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logError)
import Data.Functor.Identity (runIdentity)
import Data.List (intercalate)
import Data.Map (Map)
import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Text (Text, pack, splitOn, strip, unpack, words)
import Data.Text.Encoding (encodeUtf8)
import Distribution.InstalledPackageInfo (parseInstalledPackageInfo)
import System.Directory (doesDirectoryExist)
import System.FilePath.Posix ((</>))
import System.Process (readProcess)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import qualified Distribution.ModuleName as ModuleName
import qualified Distribution.Types.ExposedModule as ExposedModule
import qualified Distribution.Types.PackageId as PackageId
import qualified Distribution.Types.PackageName as PackageName

import qualified Data.Prune.Types as T

-- |Parse a single package output from @ghc-pkg@.
parsePkg :: (MonadLogger m) => Text -> m (Maybe (T.DependencyName, Set T.ModuleName))
parsePkg :: Text -> m (Maybe (DependencyName, Set ModuleName))
parsePkg Text
s = case ByteString
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
parseInstalledPackageInfo (Text -> ByteString
encodeUtf8 Text
s) of
  Left NonEmpty String
err -> do
    Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
pack :: String -> Text
$logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse package due to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (NonEmpty String -> String
forall a. Show a => a -> String
show NonEmpty String
err) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; original input " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
    Maybe (DependencyName, Set ModuleName)
-> m (Maybe (DependencyName, Set ModuleName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (DependencyName, Set ModuleName)
forall a. Maybe a
Nothing
  Right ([String]
_, InstalledPackageInfo
installedPackageInfo) ->
    let packageName :: String
packageName = PackageName -> String
PackageName.unPackageName (PackageName -> String)
-> (InstalledPackageInfo -> PackageName)
-> InstalledPackageInfo
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
PackageId.pkgName (PackageIdentifier -> PackageName)
-> (InstalledPackageInfo -> PackageIdentifier)
-> InstalledPackageInfo
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> PackageIdentifier
InstalledPackageInfo.sourcePackageId (InstalledPackageInfo -> String) -> InstalledPackageInfo -> String
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
installedPackageInfo
        moduleNames :: Set ModuleName
moduleNames = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleName] -> Set ModuleName)
-> (InstalledPackageInfo -> [ModuleName])
-> InstalledPackageInfo
-> Set ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExposedModule -> ModuleName) -> [ExposedModule] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> ModuleName
T.ModuleName (Text -> ModuleName)
-> (ExposedModule -> Text) -> ExposedModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text)
-> (ExposedModule -> String) -> ExposedModule -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String)
-> (ExposedModule -> [String]) -> ExposedModule -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [String]
ModuleName.components (ModuleName -> [String])
-> (ExposedModule -> ModuleName) -> ExposedModule -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExposedModule -> ModuleName
ExposedModule.exposedName) ([ExposedModule] -> [ModuleName])
-> (InstalledPackageInfo -> [ExposedModule])
-> InstalledPackageInfo
-> [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> [ExposedModule]
InstalledPackageInfo.exposedModules (InstalledPackageInfo -> Set ModuleName)
-> InstalledPackageInfo -> Set ModuleName
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
installedPackageInfo
    in case String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
packageName of
      Bool
True -> do
        Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
pack :: String -> Text
$logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse package because the name was missing; original input " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
        Maybe (DependencyName, Set ModuleName)
-> m (Maybe (DependencyName, Set ModuleName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (DependencyName, Set ModuleName)
forall a. Maybe a
Nothing
      Bool
False ->
        Maybe (DependencyName, Set ModuleName)
-> m (Maybe (DependencyName, Set ModuleName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (DependencyName, Set ModuleName)
 -> m (Maybe (DependencyName, Set ModuleName)))
-> Maybe (DependencyName, Set ModuleName)
-> m (Maybe (DependencyName, Set ModuleName))
forall a b. (a -> b) -> a -> b
$ (DependencyName, Set ModuleName)
-> Maybe (DependencyName, Set ModuleName)
forall a. a -> Maybe a
Just (Text -> DependencyName
T.DependencyName (Text -> DependencyName) -> Text -> DependencyName
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
packageName, Set ModuleName
moduleNames)

-- |Get the combined dump for the locations cabal uses for @ghc-pkg@.
getCabalRawGhcPkgs :: FilePath -> IO String
getCabalRawGhcPkgs :: String -> IO String
getCabalRawGhcPkgs String
projectRoot = do
  Config Identity
cabalConfig <- IO (Config Identity)
readConfig
  String
rawGhcVersion <- String -> [String] -> String -> IO String
readProcess String
"cabal" [String
"v2-exec", String
"ghc", String
"--", String
"--numeric-version"] String
""
  String
ghcVersion <- case (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> String
unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip) (Maybe Text -> Maybe String)
-> (String -> Maybe Text) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe Text
forall a. [a] -> Maybe a
T.lastMay ([Text] -> Maybe Text)
-> (String -> [Text]) -> String -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
words (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
rawGhcVersion of
    Maybe String
Nothing -> String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse raw GHC version for Cabal from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rawGhcVersion
    Just String
v -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
v
  let cabalPkgDbDir :: String
cabalPkgDbDir = (\String
dir -> String
dir String -> String -> String
</> (String
"ghc-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ghcVersion) String -> String -> String
</> String
"package.db") (String -> String)
-> (Config Identity -> String) -> Config Identity -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity String -> String
forall a. Identity a -> a
runIdentity (Identity String -> String)
-> (Config Identity -> Identity String)
-> Config Identity
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config Identity -> Identity String
forall (f :: * -> *). Config f -> f String
cfgStoreDir (Config Identity -> String) -> Config Identity -> String
forall a b. (a -> b) -> a -> b
$ Config Identity
cabalConfig
      localPkgDbDir :: String
localPkgDbDir = String
projectRoot String -> String -> String
</> String
"dist-newstyle" String -> String -> String
</> String
"packagedb" String -> String -> String
</> (String
"ghc-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ghcVersion)
  String
defaultPkgs <- String -> [String] -> String -> IO String
readProcess String
"cabal" [String
"v2-exec", String
"ghc-pkg", String
"dump"] String
""
  String
cabalPkgs <- String -> [String] -> String -> IO String
readProcess String
"cabal" [String
"v2-exec", String
"ghc-pkg", String
"dump", String
"--", String
"--package-db", String
cabalPkgDbDir] String
""
  Maybe String
localPkgs <- String -> IO Bool
doesDirectoryExist String
localPkgDbDir IO Bool -> (Bool -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"cabal" [String
"v2-exec", String
"ghc-pkg", String
"dump", String
"--", String
"--package-db", String
localPkgDbDir] String
""
    Bool
False -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
  String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> ([Maybe String] -> String) -> [Maybe String] -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" ([String] -> String)
-> ([Maybe String] -> [String]) -> [Maybe String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> IO String) -> [Maybe String] -> IO String
forall a b. (a -> b) -> a -> b
$ [String -> Maybe String
forall a. a -> Maybe a
Just String
defaultPkgs, String -> Maybe String
forall a. a -> Maybe a
Just String
cabalPkgs, Maybe String
localPkgs]

-- |Get the combined dump for the locations stack uses for @ghc-pkg@.
getStackRawGhcPkgs :: IO String
getStackRawGhcPkgs :: IO String
getStackRawGhcPkgs = String -> [String] -> String -> IO String
readProcess String
"stack" [String
"exec", String
"ghc-pkg", String
"dump"] String
""

-- |For the dependencies listed in the specified packages, load @ghc-pkg@ and inspect the @exposed-modules@ field.
-- Return a map of module to dependency name.
getDependencyByModule :: (MonadIO m, MonadLogger m) => FilePath -> T.BuildSystem -> [T.Package] -> m (Map T.ModuleName (Set T.DependencyName))
getDependencyByModule :: String
-> BuildSystem
-> [Package]
-> m (Map ModuleName (Set DependencyName))
getDependencyByModule String
projectRoot BuildSystem
buildSystem [Package]
packages = do
  let allDependencies :: Set DependencyName
allDependencies = (Package -> Set DependencyName) -> [Package] -> Set DependencyName
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Package -> Set DependencyName
T.packageBaseDependencies [Package]
packages Set DependencyName -> Set DependencyName -> Set DependencyName
forall a. Semigroup a => a -> a -> a
<> (Compilable -> Set DependencyName)
-> [Compilable] -> Set DependencyName
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Compilable -> Set DependencyName
T.compilableDependencies ((Package -> [Compilable]) -> [Package] -> [Compilable]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Package -> [Compilable]
T.packageCompilables [Package]
packages)
  String
rawPkgs <- case BuildSystem
buildSystem of
    BuildSystem
T.Stack -> IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getStackRawGhcPkgs
    BuildSystem
T.CabalProject -> IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getCabalRawGhcPkgs String
projectRoot
    BuildSystem
T.Cabal -> IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getCabalRawGhcPkgs String
projectRoot
  [Maybe (DependencyName, Set ModuleName)]
allPkgs <- (Text -> m (Maybe (DependencyName, Set ModuleName)))
-> [Text] -> m [Maybe (DependencyName, Set ModuleName)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> m (Maybe (DependencyName, Set ModuleName))
forall (m :: * -> *).
MonadLogger m =>
Text -> m (Maybe (DependencyName, Set ModuleName))
parsePkg ([Text] -> m [Maybe (DependencyName, Set ModuleName)])
-> (String -> [Text])
-> String
-> m [Maybe (DependencyName, Set ModuleName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
splitOn Text
"\n---\n" (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> m [Maybe (DependencyName, Set ModuleName)])
-> String -> m [Maybe (DependencyName, Set ModuleName)]
forall a b. (a -> b) -> a -> b
$ String
rawPkgs
  Map ModuleName (Set DependencyName)
-> m (Map ModuleName (Set DependencyName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Map ModuleName (Set DependencyName)
 -> m (Map ModuleName (Set DependencyName)))
-> ([Maybe (DependencyName, Set ModuleName)]
    -> Map ModuleName (Set DependencyName))
-> [Maybe (DependencyName, Set ModuleName)]
-> m (Map ModuleName (Set DependencyName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModuleName, Set DependencyName)
 -> Map ModuleName (Set DependencyName)
 -> Map ModuleName (Set DependencyName))
-> Map ModuleName (Set DependencyName)
-> [(ModuleName, Set DependencyName)]
-> Map ModuleName (Set DependencyName)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(ModuleName
moduleName, Set DependencyName
dependencyNames) Map ModuleName (Set DependencyName)
acc -> (Set DependencyName -> Set DependencyName -> Set DependencyName)
-> ModuleName
-> Set DependencyName
-> Map ModuleName (Set DependencyName)
-> Map ModuleName (Set DependencyName)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set DependencyName -> Set DependencyName -> Set DependencyName
forall a. Semigroup a => a -> a -> a
(<>) ModuleName
moduleName Set DependencyName
dependencyNames Map ModuleName (Set DependencyName)
acc) Map ModuleName (Set DependencyName)
forall a. Monoid a => a
mempty
    ([(ModuleName, Set DependencyName)]
 -> Map ModuleName (Set DependencyName))
-> ([Maybe (DependencyName, Set ModuleName)]
    -> [(ModuleName, Set DependencyName)])
-> [Maybe (DependencyName, Set ModuleName)]
-> Map ModuleName (Set DependencyName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DependencyName, Set ModuleName)
 -> [(ModuleName, Set DependencyName)])
-> [(DependencyName, Set ModuleName)]
-> [(ModuleName, Set DependencyName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(DependencyName
dependencyName, Set ModuleName
moduleNames) -> (, DependencyName -> Set DependencyName
forall a. a -> Set a
Set.singleton DependencyName
dependencyName) (ModuleName -> (ModuleName, Set DependencyName))
-> [ModuleName] -> [(ModuleName, Set DependencyName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
moduleNames)
    ([(DependencyName, Set ModuleName)]
 -> [(ModuleName, Set DependencyName)])
-> ([Maybe (DependencyName, Set ModuleName)]
    -> [(DependencyName, Set ModuleName)])
-> [Maybe (DependencyName, Set ModuleName)]
-> [(ModuleName, Set DependencyName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DependencyName, Set ModuleName) -> Bool)
-> [(DependencyName, Set ModuleName)]
-> [(DependencyName, Set ModuleName)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((DependencyName -> Set DependencyName -> Bool)
-> Set DependencyName -> DependencyName -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip DependencyName -> Set DependencyName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set DependencyName
allDependencies (DependencyName -> Bool)
-> ((DependencyName, Set ModuleName) -> DependencyName)
-> (DependencyName, Set ModuleName)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DependencyName, Set ModuleName) -> DependencyName
forall a b. (a, b) -> a
fst)
    ([(DependencyName, Set ModuleName)]
 -> [(DependencyName, Set ModuleName)])
-> ([Maybe (DependencyName, Set ModuleName)]
    -> [(DependencyName, Set ModuleName)])
-> [Maybe (DependencyName, Set ModuleName)]
-> [(DependencyName, Set ModuleName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (DependencyName, Set ModuleName)]
-> [(DependencyName, Set ModuleName)]
forall a. [Maybe a] -> [a]
catMaybes
    ([Maybe (DependencyName, Set ModuleName)]
 -> m (Map ModuleName (Set DependencyName)))
-> [Maybe (DependencyName, Set ModuleName)]
-> m (Map ModuleName (Set DependencyName))
forall a b. (a -> b) -> a -> b
$ [Maybe (DependencyName, Set ModuleName)]
allPkgs