Use batched ghc-pkg unregister implemented in GHC 8.0.1

qrilka · qrilka · commit 77df52d8daa9 · 2019-02-04T22:46:46.000+03:00
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -87,6 +87,8 @@ Other enhancements:
   [#4463](https://github.com/commercialhaskell/stack/issues/4463)
 * Add `--cabal-files` flag to `stack ide targets` command.
 * Add `--stdout` flag to all `stack ide` subcommands.
+* Use batches when unregistering packages with `ghc-pkg`.
+  (See [#2662](https://github.com/commercialhaskell/stack/issues/2662))
 
 Bug fixes:
 
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -41,6 +41,7 @@ import           Data.Conduit.Process.Typed
                      runProcess_, getStdout, getStderr, createSource)
 import qualified Data.Conduit.Text as CT
 import           Data.List hiding (any)
+import           Data.List.Split (chunksOf)
 import qualified Data.Map.Strict as M
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -584,14 +585,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
         [] -> return ()
         ids -> do
             localDB <- packageDatabaseLocal
-            forM_ ids $ \(id', (ident, reason)) -> do
-                logInfo $
-                    fromString (packageIdentifierString ident) <>
-                    ": unregistering" <>
-                    if T.null reason
-                        then ""
-                        else " (" <> RIO.display reason <> ")"
-                unregisterGhcPkgId wc cv localDB id' ident
+            unregisterPackages wc cv localDB ids
 
     liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap ->
         foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan)
@@ -661,6 +655,35 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
                   $ Map.elems
                   $ planUnregisterLocal plan
 
+unregisterPackages ::
+       (HasProcessContext env, HasLogFunc env)
+    => WhichCompiler
+    -> ActualCompiler
+    -> Path Abs Dir
+    -> [(GhcPkgId, (PackageIdentifier, Text))]
+    -> RIO env ()
+unregisterPackages wc ac localDB ids = do
+    let logReason ident reason =
+            logInfo $
+            fromString (packageIdentifierString ident) <> ": unregistering" <>
+            if T.null reason
+                then ""
+                else " (" <> RIO.display reason <> ")"
+    case ac of
+        ACGhc v | v >= mkVersion [8, 0, 1] -> do
+                let batchSize = 500
+                for_ (chunksOf batchSize ids) $ \batch -> do
+                    for_ batch $ \(_, (ident, reason)) -> logReason ident reason
+                    unregisterGhcPkgIds wc localDB $ map fst batch
+        ACGhc v | v >= mkVersion [7, 9] ->
+                for_ ids $ \(gid, (ident, reason)) -> do
+                    logReason ident reason
+                    unregisterGhcPkgIds wc localDB [gid]
+        _ -> do
+            for_ ids $ \(_gid, (ident, reason)) -> do
+                logReason ident reason
+                unregisterSinglePackageId wc localDB ident
+
 toActions :: HasEnvConfig env
           => InstalledMap
           -> Maybe (MVar ())
diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs
@@ -10,7 +10,8 @@ module Stack.GhcPkg
   (getGlobalDB
   ,findGhcPkgField
   ,createDatabase
-  ,unregisterGhcPkgId
+  ,unregisterSinglePackageId
+  ,unregisterGhcPkgIds
   ,getCabalPkgVer
   ,ghcPkgExeName
   ,ghcPkgPathEnvVar
@@ -23,7 +24,6 @@ import qualified Data.ByteString.Lazy as BL
 import           Data.List
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
-import           Distribution.Version (mkVersion)
 import           Path (parent, (</>))
 import           Path.Extra (toFilePathNoTrailingSep)
 import           Path.IO
@@ -147,25 +147,35 @@ findGhcPkgVersion wc pkgDbs name = do
         Just !v -> return (parseVersion $ T.unpack v)
         _ -> return Nothing
 
-unregisterGhcPkgId :: (HasProcessContext env, HasLogFunc env)
+unregisterSinglePackageId :: (HasProcessContext env, HasLogFunc env)
+                          => WhichCompiler
+                          -> Path Abs Dir -- ^ package database
+                          -> PackageIdentifier
+                          -> RIO env ()
+unregisterSinglePackageId wc pkgDb ident = do
+    eres <- ghcPkg wc [pkgDb] args
+    case eres of
+        Left e -> logWarn $ displayShow e
+        Right _ -> return ()
+  where
+    args = "unregister" : "--user" : "--force" :
+           [packageIdentifierString ident]
+
+-- | unregister list of package ghcids, batching available from GHC 8.0.1,
+-- using GHC package id available from GHC 7.9(?)
+unregisterGhcPkgIds :: (HasProcessContext env, HasLogFunc env)
                     => WhichCompiler
-                    -> ActualCompiler
                     -> Path Abs Dir -- ^ package database
-                    -> GhcPkgId
-                    -> PackageIdentifier
+                    -> [GhcPkgId]
                     -> RIO env ()
-unregisterGhcPkgId wc cv pkgDb gid ident = do
+unregisterGhcPkgIds wc pkgDb gids = do
     eres <- ghcPkg wc [pkgDb] args
     case eres of
         Left e -> logWarn $ displayShow e
         Right _ -> return ()
   where
-    -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead
     args = "unregister" : "--user" : "--force" :
-        (case cv of
-            ACGhc v | v < mkVersion [7, 9] ->
-                [packageIdentifierString ident]
-            _ -> ["--ipid", ghcPkgIdString gid])
+        concatMap (\gid -> ["--ipid", ghcPkgIdString gid]) gids
 
 -- | Get the version of Cabal from the global package database.
 getCabalPkgVer :: (HasProcessContext env, HasLogFunc env)
