-- |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.Package] -> IO (Map T.ModuleName T.DependencyName)
getDependencyByModule :: [Package] -> IO (Map ModuleName DependencyName)
getDependencyByModule [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 <- String -> [String] -> String -> IO String
readProcess String
"stack" [String
"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 DependencyName -> IO (Map ModuleName DependencyName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Map ModuleName DependencyName
 -> IO (Map ModuleName DependencyName))
-> ([(DependencyName, Set ModuleName)]
    -> Map ModuleName DependencyName)
-> [(DependencyName, Set ModuleName)]
-> IO (Map ModuleName DependencyName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ModuleName, DependencyName)] -> Map ModuleName DependencyName
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    ([(ModuleName, DependencyName)] -> Map ModuleName DependencyName)
-> ([(DependencyName, Set ModuleName)]
    -> [(ModuleName, DependencyName)])
-> [(DependencyName, Set ModuleName)]
-> Map ModuleName DependencyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DependencyName, Set ModuleName)
 -> [(ModuleName, DependencyName)])
-> [(DependencyName, Set ModuleName)]
-> [(ModuleName, DependencyName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(DependencyName
dependencyName, Set ModuleName
moduleNames) -> (, DependencyName
dependencyName) (ModuleName -> (ModuleName, DependencyName))
-> [ModuleName] -> [(ModuleName, 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, DependencyName)])
-> ([(DependencyName, Set ModuleName)]
    -> [(DependencyName, Set ModuleName)])
-> [(DependencyName, Set ModuleName)]
-> [(ModuleName, 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 DependencyName))
-> [(DependencyName, Set ModuleName)]
-> IO (Map ModuleName DependencyName)
forall a b. (a -> b) -> a -> b
$ [(DependencyName, Set ModuleName)]
allPkgs