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
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)
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]
getStackRawGhcPkgs :: IO String
getStackRawGhcPkgs :: IO String
getStackRawGhcPkgs = String -> [String] -> String -> IO String
readProcess String
"stack" [String
"exec", String
"ghc-pkg", String
"dump"] String
""
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