-- |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, unwords, words)
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 Data.Prune.ImportParser (parseDependencyName, parseExposedModules)
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 = do
  let dependencyNameInput :: String
dependencyNameInput = Text -> String
unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unwords ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
"name:") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
words (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
s
      moduleNamesInput :: String
moduleNamesInput = Text -> String
unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unwords ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) Text
"exposed-modules:") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
words (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
s
  Maybe DependencyName
dependencyNameMay <- case String -> Either String (Maybe DependencyName)
parseDependencyName String
dependencyNameInput of
    Left 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 ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
$logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse dependency name due to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (String -> String
forall a. Show a => a -> String
show 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
<> String -> Text
pack String
dependencyNameInput
      Maybe DependencyName -> m (Maybe DependencyName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DependencyName
forall a. Maybe a
Nothing
    Right Maybe DependencyName
x -> Maybe DependencyName -> m (Maybe DependencyName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DependencyName
x
  Set ModuleName
moduleNames <- case String -> Either String (Set ModuleName)
parseExposedModules String
moduleNamesInput of
    Left 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 ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
$logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse module names due to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (String -> String
forall a. Show a => a -> String
show 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
<> String -> Text
pack String
moduleNamesInput
      Set ModuleName -> m (Set ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set ModuleName
forall a. Monoid a => a
mempty
    Right Set ModuleName
x -> Set ModuleName -> m (Set ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set ModuleName
x
  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
$ (, Set ModuleName
moduleNames) (DependencyName -> (DependencyName, Set ModuleName))
-> Maybe DependencyName -> Maybe (DependencyName, Set ModuleName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DependencyName
dependencyNameMay

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
""

-- |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