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