Merge pull request #1936 from sjakobi/fewer-get-package-caches

In 'loadSourceMap', load the package caches only when necessary

src/Stack/Build/Source.hs

@@ -61,7 +61,7 @@ import           Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan,
                                   parseCustomMiniBuildPlan)
 import           Stack.Constants (wiredInPackages)
 import           Stack.Package
-import           Stack.PackageIndex (getPackageCaches)
+import           Stack.PackageIndex (getPackageVersions)
 import           Stack.Types
 
 import qualified System.Directory as D
@@ -81,19 +81,12 @@ loadSourceMap needTargets boptsCli = do
     bconfig <- asks getBuildConfig
     rawLocals <- getLocalPackageViews
     (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets boptsCli
-    caches <- getPackageCaches
-    let latestVersion =
-            Map.fromListWith max $
-            map toTuple $
-            Map.keys caches
-
     -- Extend extra-deps to encompass targets requested on the command line
     -- that are not in the snapshot.
     extraDeps0 <- extendExtraDeps
         (bcExtraDeps bconfig)
         cliExtraDeps
         (Map.keysSet $ Map.filter (== STUnknown) targets)
-        latestVersion
 
     locals <- mapM (loadLocalPackage boptsCli targets) $ Map.toList rawLocals
     checkFlagsUsed boptsCli locals extraDeps0 (mbpPackages mbp0)
@@ -434,31 +427,35 @@ localFlags boptsflags bconfig name = Map.unions
 -- Originally part of https://github.com/commercialhaskell/stack/issues/272,
 -- this was then superseded by
 -- https://github.com/commercialhaskell/stack/issues/651
-extendExtraDeps :: (MonadThrow m, MonadReader env m, HasBuildConfig env)
-                => Map PackageName Version -- ^ original extra deps
-                -> Map PackageName Version -- ^ package identifiers from the command line
-                -> Set PackageName -- ^ all packages added on the command line
-                -> Map PackageName Version -- ^ latest versions in indices
-                -> m (Map PackageName Version) -- ^ new extradeps
-extendExtraDeps extraDeps0 cliExtraDeps unknowns latestVersion
-    | null errs = return $ Map.unions $ extraDeps1 : unknowns'
-    | otherwise = do
-        bconfig <- asks getBuildConfig
-        throwM $ UnknownTargets
-            (Set.fromList errs)
-            Map.empty -- TODO check the cliExtraDeps for presence in index
-            (bcStackYaml bconfig)
+extendExtraDeps
+    :: (HasBuildConfig env, MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
+    => Map PackageName Version -- ^ original extra deps
+    -> Map PackageName Version -- ^ package identifiers from the command line
+    -> Set PackageName -- ^ all packages added on the command line
+    -> m (Map PackageName Version) -- ^ new extradeps
+extendExtraDeps extraDeps0 cliExtraDeps unknowns = do
+    (errs, unknowns') <- fmap partitionEithers $ mapM addUnknown $ Set.toList unknowns
+    case errs of
+        [] -> return $ Map.unions $ extraDeps1 : unknowns'
+        _ -> do
+            bconfig <- asks getBuildConfig
+            throwM $ UnknownTargets
+                (Set.fromList errs)
+                Map.empty -- TODO check the cliExtraDeps for presence in index
+                (bcStackYaml bconfig)
   where
     extraDeps1 = Map.union extraDeps0 cliExtraDeps
-
-    (errs, unknowns') = partitionEithers $ map addUnknown $ Set.toList unknowns
-    addUnknown pn =
+    addUnknown pn = do
         case Map.lookup pn extraDeps1 of
-            Just _ -> Right Map.empty
-            Nothing ->
-                case Map.lookup pn latestVersion of
-                    Just v -> Right $ Map.singleton pn v
-                    Nothing -> Left pn
+            Just _ -> return (Right Map.empty)
+            Nothing -> do
+                mlatestVersion <- getLatestVersion pn
+                case mlatestVersion of
+                    Just v -> return (Right $ Map.singleton pn v)
+                    Nothing -> return (Left pn)
+    getLatestVersion pn = do
+        vs <- getPackageVersions pn
+        return (fmap fst (Set.maxView vs))
 
 -- | Compare the current filesystem state to the cached information, and
 -- determine (1) if the files are dirty, and (2) the new cache values.

src/Stack/PackageIndex.hs

@@ -19,6 +19,7 @@
 module Stack.PackageIndex
     ( updateAllIndices
     , getPackageCaches
+    , getPackageVersions
     , clearPackageCaches
     ) where
 
@@ -46,6 +47,8 @@ import           Data.IORef (readIORef, writeIORef)
 import           Data.Int (Int64)
 import           Data.Map (Map)
 import qualified Data.Map.Strict as Map
+import           Data.Set (Set)
+import qualified Data.Set as Set
 import           Data.Monoid
 import           Data.Text (Text)
 import qualified Data.Text as T
@@ -344,13 +347,24 @@ deleteCache indexName' = do
         Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e)
         Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp)
 
-
--- | Load the cached package URLs, or created the cache if necessary.
+-- | Get the known versions for a given package from the package caches.
+--
+-- See 'getPackageCaches' for performance notes.
+getPackageVersions
+    :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
+    => PackageName
+    -> m (Set Version)
+getPackageVersions pkgName = do
+    caches <- getPackageCaches
+    return (Set.fromList [v | PackageIdentifier n v <- Map.keys caches, n == pkgName])
+
+-- | Load the package caches, or create the caches if necessary.
 --
 -- This has two levels of caching: in memory, and the on-disk cache. So,
 -- feel free to call this function multiple times.
-getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
-                 => m (Map PackageIdentifier (PackageIndex, PackageCache))
+getPackageCaches
+    :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
+    => m (Map PackageIdentifier (PackageIndex, PackageCache))
 getPackageCaches = do
     menv <- getMinimalEnvOverride
     config <- askConfig