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

import Prelude hiding (unwords, words)

import Data.Map (Map)
import Data.Set (Set)
import Data.Text (Text, pack, splitOn, strip, unpack, unwords, words)
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 :: Text -> IO (T.DependencyName, Set T.ModuleName)
parsePkg :: Text -> IO (DependencyName, Set ModuleName)
parsePkg Text
s = do
  DependencyName
dependencyName <- String -> IO DependencyName
parseDependencyName (String -> IO DependencyName)
-> (Text -> String) -> Text -> IO DependencyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> IO DependencyName) -> Text -> IO DependencyName
forall a b. (a -> b) -> a -> b
$ Text
s
  Set ModuleName
moduleNames <- String -> IO (Set ModuleName)
parseExposedModules (String -> IO (Set ModuleName))
-> (Text -> String) -> Text -> IO (Set ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> IO (Set ModuleName)) -> Text -> IO (Set ModuleName)
forall a b. (a -> b) -> a -> b
$ Text
s
  (DependencyName, Set ModuleName)
-> IO (DependencyName, Set ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DependencyName
dependencyName, Set ModuleName
moduleNames)

-- |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 :: T.BuildSystem -> [T.Package] -> IO (Map T.ModuleName (Set T.DependencyName))
getDependencyByModule :: BuildSystem
-> [Package] -> IO (Map ModuleName (Set DependencyName))
getDependencyByModule 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 -> String -> [String] -> String -> IO String
readProcess String
"stack" [String
"exec", String
"ghc-pkg", String
"dump"] String
""
    BuildSystem
T.CabalProject -> String -> [String] -> String -> IO String
readProcess String
"cabal" [String
"v2-exec", String
"ghc-pkg", String
"dump"] String
""
    BuildSystem
T.Cabal -> String -> [String] -> String -> IO String
readProcess String
"cabal" [String
"v2-exec", String
"ghc-pkg", String
"dump"] String
""
  [(DependencyName, Set ModuleName)]
allPkgs <- (Text -> IO (DependencyName, Set ModuleName))
-> [Text] -> IO [(DependencyName, Set ModuleName)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> IO (DependencyName, Set ModuleName)
parsePkg ([Text] -> IO [(DependencyName, Set ModuleName)])
-> (String -> [Text])
-> String
-> IO [(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 -> IO [(DependencyName, Set ModuleName)])
-> String -> IO [(DependencyName, Set ModuleName)]
forall a b. (a -> b) -> a -> b
$ String
rawPkgs
  Map ModuleName (Set DependencyName)
-> IO (Map ModuleName (Set DependencyName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Map ModuleName (Set DependencyName)
 -> IO (Map ModuleName (Set DependencyName)))
-> ([(DependencyName, Set ModuleName)]
    -> Map ModuleName (Set DependencyName))
-> [(DependencyName, Set ModuleName)]
-> IO (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))
-> ([(DependencyName, Set ModuleName)]
    -> [(ModuleName, Set DependencyName)])
-> [(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)])
-> ([(DependencyName, Set ModuleName)]
    -> [(DependencyName, Set ModuleName)])
-> [(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)]
 -> IO (Map ModuleName (Set DependencyName)))
-> [(DependencyName, Set ModuleName)]
-> IO (Map ModuleName (Set DependencyName))
forall a b. (a -> b) -> a -> b
$ [(DependencyName, Set ModuleName)]
allPkgs