Merge pull request #4554 from commercialhaskell/batched-unregister

Use batched ghc-pkg unregister implemented in GHC 8.0.1

ChangeLog.md

@@ -91,6 +91,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:
 

src/Stack/Build/Execute.hs

@@ -41,6 +41,9 @@ import           Data.Conduit.Process.Typed
                      runProcess_, getStdout, getStderr, createSource)
 import qualified Data.Conduit.Text as CT
 import           Data.List hiding (any)
+import           Data.List.NonEmpty (NonEmpty(..), nonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty (toList)
+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
@@ -580,18 +583,11 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
     when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports
     cv <- view actualCompilerVersionL
     let wc = view whichCompilerL cv
-    case Map.toList $ planUnregisterLocal plan of
-        [] -> return ()
-        ids -> do
+    case nonEmpty . Map.toList $ planUnregisterLocal plan of
+        Nothing -> return ()
+        Just 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 cv localDB ids
 
     liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap ->
         foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan)
@@ -661,6 +657,49 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
                   $ Map.elems
                   $ planUnregisterLocal plan
 
+unregisterPackages ::
+       (HasProcessContext env, HasLogFunc env, HasPlatform env)
+    => ActualCompiler
+    -> Path Abs Dir
+    -> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
+    -> RIO env ()
+unregisterPackages cv localDB ids = do
+    let wc = view whichCompilerL cv
+    let logReason ident reason =
+            logInfo $
+            fromString (packageIdentifierString ident) <> ": unregistering" <>
+            if T.null reason
+                then ""
+                else " (" <> RIO.display reason <> ")"
+    let unregisterSinglePkg select (gid, (ident, reason)) = do
+            logReason ident reason
+            unregisterGhcPkgIds wc localDB $ select ident gid :| []
+
+    case cv of
+        -- GHC versions >= 8.0.1 support batch unregistering of packages. See
+        -- https://github.com/commercialhaskell/stack/pull/4554
+        ACGhc v | v >= mkVersion [8, 0, 1] -> do
+                platform <- view platformL
+                -- According to https://support.microsoft.com/en-us/help/830473/command-prompt-cmd-exe-command-line-string-limitation
+                -- the maximum command line length on Windows since XP is 8191 characters.
+                -- We use conservative batch size of 100 ids on this OS thus argument name '-ipid', package name,
+                -- its version and a hash should fit well into this limit.
+                -- On Unix-like systems we're limited by ARG_MAX which is normally hundreds
+                -- of kilobytes so batch size of 500 should work fine.
+                let batchSize = case platform of
+                      Platform _ Windows -> 100
+                      _ -> 500
+                let chunksOfNE size = catMaybes . map nonEmpty . chunksOf size . NonEmpty.toList
+                for_ (chunksOfNE batchSize ids) $ \batch -> do
+                    for_ batch $ \(_, (ident, reason)) -> logReason ident reason
+                    unregisterGhcPkgIds wc localDB $ fmap (Right . fst) batch
+
+        -- GHC versions >= 7.9 support unregistering of packages via their
+        -- GhcPkgId.
+        ACGhc v | v >= mkVersion [7, 9] -> for_ ids . unregisterSinglePkg $ \_ident gid -> Right gid
+
+        _ -> for_ ids . unregisterSinglePkg $ \ident _gid -> Left ident
+
 toActions :: HasEnvConfig env
           => InstalledMap
           -> Maybe (MVar ())

src/Stack/GhcPkg.hs

@@ -10,7 +10,7 @@ module Stack.GhcPkg
   (getGlobalDB
   ,findGhcPkgField
   ,createDatabase
-  ,unregisterGhcPkgId
+  ,unregisterGhcPkgIds
   ,getCabalPkgVer
   ,ghcPkgExeName
   ,ghcPkgPathEnvVar
@@ -21,9 +21,9 @@ import           Stack.Prelude
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as BL
 import           Data.List
+import           Data.List.NonEmpty (NonEmpty(..))
 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,24 @@ findGhcPkgVersion wc pkgDbs name = do
         Just !v -> return (parseVersion $ T.unpack v)
         _ -> return Nothing
 
-unregisterGhcPkgId :: (HasProcessContext env, HasLogFunc env)
+-- | unregister list of package ghcids, batching available from GHC 8.0.1,
+-- using GHC package id where available (from GHC 7.9)
+unregisterGhcPkgIds :: (HasProcessContext env, HasLogFunc env)
                     => WhichCompiler
-                    -> ActualCompiler
                     -> Path Abs Dir -- ^ package database
-                    -> GhcPkgId
-                    -> PackageIdentifier
+                    -> NonEmpty (Either PackageIdentifier GhcPkgId)
                     -> RIO env ()
-unregisterGhcPkgId wc cv pkgDb gid ident = do
+unregisterGhcPkgIds wc pkgDb epgids = 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 (either
+            (\ident -> [packageIdentifierString ident])
+            (\gid -> ["--ipid", ghcPkgIdString gid]))
+            epgids
 
 -- | Get the version of Cabal from the global package database.
 getCabalPkgVer :: (HasProcessContext env, HasLogFunc env)