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

import Prelude hiding (words)

import Data.Foldable (find)
import Data.Map (Map)
import Data.Maybe (mapMaybe)
import Data.Text (Text, isPrefixOf, pack, strip, unpack, words)
import Data.Traversable (for)
import System.Exit (ExitCode(ExitFailure, ExitSuccess))
import Turtle (shellStrict)
import qualified Data.Map as Map
import qualified Data.Set as Set

import Data.Prune.ImportParser (parseExposedModules)
import qualified Data.Prune.Types as T

-- |Run a shell command or exit if it fails.
runOrFail :: Text -> IO Text
runOrFail :: Text -> IO Text
runOrFail Text
cmd = Text -> Shell Line -> IO (ExitCode, Text)
forall (io :: * -> *).
MonadIO io =>
Text -> Shell Line -> io (ExitCode, Text)
shellStrict Text
cmd Shell Line
forall a. Monoid a => a
mempty IO (ExitCode, Text) -> ((ExitCode, Text) -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  (ExitCode
ExitSuccess, Text
out) -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
out
  (ExitFailure Int
_, Text
out) -> String -> IO Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Text) -> (Text -> String) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
"Failed to \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" due to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
out

-- |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 :: FilePath -> [T.Package] -> IO (Map T.ModuleName T.DependencyName)
getDependencyByModule :: String -> [Package] -> IO (Map ModuleName DependencyName)
getDependencyByModule String
stackYamlFile [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)
      tupleDependency :: Text -> Maybe (DependencyName, Text)
tupleDependency Text
x = (, Text
x) (DependencyName -> (DependencyName, Text))
-> Maybe DependencyName -> Maybe (DependencyName, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DependencyName -> Bool)
-> Set DependencyName -> Maybe DependencyName
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\DependencyName
d -> Text -> Text -> Bool
isPrefixOf (DependencyName -> Text
T.unDependencyName DependencyName
d) Text
x) Set DependencyName
allDependencies
  Text
compilerBin <- Text -> Text
strip (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
runOrFail (Text
"stack --stack-yaml " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
stackYamlFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" path --compiler-bin")
  Text
snapshotPkgDb <- Text -> Text
strip (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
runOrFail (Text
"stack --stack-yaml " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
stackYamlFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" path --snapshot-pkg-db")
  Text
globalPkgDb <- Text -> Text
strip (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
runOrFail (Text
"stack --stack-yaml " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
stackYamlFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" path --global-pkg-db")
  Text
localPkgDb <- Text -> Text
strip (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
runOrFail (Text
"stack --stack-yaml " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
stackYamlFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" path --local-pkg-db")
  let snapshotGhcPkg :: Text
snapshotGhcPkg = Text
compilerBin Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/ghc-pkg --package-db " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
snapshotPkgDb
      globalGhcPkg :: Text
globalGhcPkg = Text
compilerBin Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/ghc-pkg --package-db " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
globalPkgDb
      localGhcPkg :: Text
localGhcPkg = Text
compilerBin Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/ghc-pkg --package-db " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
localPkgDb
  [(DependencyName, Text)]
snapshotPkgs <- (Text -> Maybe (DependencyName, Text))
-> [Text] -> [(DependencyName, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (DependencyName, Text)
tupleDependency ([Text] -> [(DependencyName, Text)])
-> (Text -> [Text]) -> Text -> [(DependencyName, 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 -> [(DependencyName, Text)])
-> IO Text -> IO [(DependencyName, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
runOrFail (Text
snapshotGhcPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" list --simple-output")
  [(DependencyName, Text)]
globalPkgs <- (Text -> Maybe (DependencyName, Text))
-> [Text] -> [(DependencyName, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (DependencyName, Text)
tupleDependency ([Text] -> [(DependencyName, Text)])
-> (Text -> [Text]) -> Text -> [(DependencyName, 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 -> [(DependencyName, Text)])
-> IO Text -> IO [(DependencyName, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
runOrFail (Text
globalGhcPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" list --simple-output")
  [(DependencyName, Text)]
localPkgs <- (Text -> Maybe (DependencyName, Text))
-> [Text] -> [(DependencyName, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (DependencyName, Text)
tupleDependency ([Text] -> [(DependencyName, Text)])
-> (Text -> [Text]) -> Text -> [(DependencyName, 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 -> [(DependencyName, Text)])
-> IO Text -> IO [(DependencyName, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
runOrFail (Text
localGhcPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" list --simple-output")
  Map ModuleName DependencyName
snapshotDependencyByModule <- ([Map ModuleName DependencyName] -> Map ModuleName DependencyName)
-> IO [Map ModuleName DependencyName]
-> IO (Map ModuleName DependencyName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map ModuleName DependencyName] -> Map ModuleName DependencyName
forall a. Monoid a => [a] -> a
mconcat (IO [Map ModuleName DependencyName]
 -> IO (Map ModuleName DependencyName))
-> (((DependencyName, Text) -> IO (Map ModuleName DependencyName))
    -> IO [Map ModuleName DependencyName])
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO (Map ModuleName DependencyName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(DependencyName, Text)]
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO [Map ModuleName DependencyName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(DependencyName, Text)]
snapshotPkgs (((DependencyName, Text) -> IO (Map ModuleName DependencyName))
 -> IO (Map ModuleName DependencyName))
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO (Map ModuleName DependencyName)
forall a b. (a -> b) -> a -> b
$ \(DependencyName
dependencyName, Text
pkg) -> do
    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
strip (Text -> IO (Set ModuleName)) -> IO Text -> IO (Set ModuleName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> IO Text
runOrFail (Text
snapshotGhcPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" exposed-modules")
    Map ModuleName DependencyName -> IO (Map ModuleName DependencyName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ModuleName DependencyName
 -> IO (Map ModuleName DependencyName))
-> (Set ModuleName -> Map ModuleName 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)
-> (Set ModuleName -> [(ModuleName, DependencyName)])
-> Set ModuleName
-> Map ModuleName DependencyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> (ModuleName, DependencyName))
-> [ModuleName] -> [(ModuleName, DependencyName)]
forall a b. (a -> b) -> [a] -> [b]
map (, DependencyName
dependencyName) ([ModuleName] -> [(ModuleName, DependencyName)])
-> (Set ModuleName -> [ModuleName])
-> Set ModuleName
-> [(ModuleName, DependencyName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList (Set ModuleName -> IO (Map ModuleName DependencyName))
-> Set ModuleName -> IO (Map ModuleName DependencyName)
forall a b. (a -> b) -> a -> b
$ Set ModuleName
moduleNames
  Map ModuleName DependencyName
globalDependencyByModule <- ([Map ModuleName DependencyName] -> Map ModuleName DependencyName)
-> IO [Map ModuleName DependencyName]
-> IO (Map ModuleName DependencyName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map ModuleName DependencyName] -> Map ModuleName DependencyName
forall a. Monoid a => [a] -> a
mconcat (IO [Map ModuleName DependencyName]
 -> IO (Map ModuleName DependencyName))
-> (((DependencyName, Text) -> IO (Map ModuleName DependencyName))
    -> IO [Map ModuleName DependencyName])
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO (Map ModuleName DependencyName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(DependencyName, Text)]
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO [Map ModuleName DependencyName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(DependencyName, Text)]
globalPkgs (((DependencyName, Text) -> IO (Map ModuleName DependencyName))
 -> IO (Map ModuleName DependencyName))
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO (Map ModuleName DependencyName)
forall a b. (a -> b) -> a -> b
$ \(DependencyName
dependencyName, Text
pkg) -> do
    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
strip (Text -> IO (Set ModuleName)) -> IO Text -> IO (Set ModuleName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> IO Text
runOrFail (Text
globalGhcPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" exposed-modules")
    Map ModuleName DependencyName -> IO (Map ModuleName DependencyName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ModuleName DependencyName
 -> IO (Map ModuleName DependencyName))
-> (Set ModuleName -> Map ModuleName 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)
-> (Set ModuleName -> [(ModuleName, DependencyName)])
-> Set ModuleName
-> Map ModuleName DependencyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> (ModuleName, DependencyName))
-> [ModuleName] -> [(ModuleName, DependencyName)]
forall a b. (a -> b) -> [a] -> [b]
map (, DependencyName
dependencyName) ([ModuleName] -> [(ModuleName, DependencyName)])
-> (Set ModuleName -> [ModuleName])
-> Set ModuleName
-> [(ModuleName, DependencyName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList (Set ModuleName -> IO (Map ModuleName DependencyName))
-> Set ModuleName -> IO (Map ModuleName DependencyName)
forall a b. (a -> b) -> a -> b
$ Set ModuleName
moduleNames
  Map ModuleName DependencyName
localDependencyByModule <- ([Map ModuleName DependencyName] -> Map ModuleName DependencyName)
-> IO [Map ModuleName DependencyName]
-> IO (Map ModuleName DependencyName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map ModuleName DependencyName] -> Map ModuleName DependencyName
forall a. Monoid a => [a] -> a
mconcat (IO [Map ModuleName DependencyName]
 -> IO (Map ModuleName DependencyName))
-> (((DependencyName, Text) -> IO (Map ModuleName DependencyName))
    -> IO [Map ModuleName DependencyName])
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO (Map ModuleName DependencyName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(DependencyName, Text)]
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO [Map ModuleName DependencyName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(DependencyName, Text)]
localPkgs (((DependencyName, Text) -> IO (Map ModuleName DependencyName))
 -> IO (Map ModuleName DependencyName))
-> ((DependencyName, Text) -> IO (Map ModuleName DependencyName))
-> IO (Map ModuleName DependencyName)
forall a b. (a -> b) -> a -> b
$ \(DependencyName
dependencyName, Text
pkg) -> do
    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
strip (Text -> IO (Set ModuleName)) -> IO Text -> IO (Set ModuleName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> IO Text
runOrFail (Text
localGhcPkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" exposed-modules")
    Map ModuleName DependencyName -> IO (Map ModuleName DependencyName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ModuleName DependencyName
 -> IO (Map ModuleName DependencyName))
-> (Set ModuleName -> Map ModuleName 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)
-> (Set ModuleName -> [(ModuleName, DependencyName)])
-> Set ModuleName
-> Map ModuleName DependencyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> (ModuleName, DependencyName))
-> [ModuleName] -> [(ModuleName, DependencyName)]
forall a b. (a -> b) -> [a] -> [b]
map (, DependencyName
dependencyName) ([ModuleName] -> [(ModuleName, DependencyName)])
-> (Set ModuleName -> [ModuleName])
-> Set ModuleName
-> [(ModuleName, DependencyName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList (Set ModuleName -> IO (Map ModuleName DependencyName))
-> Set ModuleName -> IO (Map ModuleName DependencyName)
forall a b. (a -> b) -> a -> b
$ Set ModuleName
moduleNames
  Map ModuleName DependencyName -> IO (Map ModuleName DependencyName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ModuleName DependencyName
 -> IO (Map ModuleName DependencyName))
-> Map ModuleName DependencyName
-> IO (Map ModuleName DependencyName)
forall a b. (a -> b) -> a -> b
$ Map ModuleName DependencyName
snapshotDependencyByModule Map ModuleName DependencyName
-> Map ModuleName DependencyName -> Map ModuleName DependencyName
forall a. Semigroup a => a -> a -> a
<> Map ModuleName DependencyName
globalDependencyByModule Map ModuleName DependencyName
-> Map ModuleName DependencyName -> Map ModuleName DependencyName
forall a. Semigroup a => a -> a -> a
<> Map ModuleName DependencyName
localDependencyByModule