From 2ca989fd6e7867941a972f41d983d541fa460d64 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 22 Mar 2016 00:03:16 +0100 Subject: [PATCH] In 'loadSourceMap', load the package caches only when necessary See https://github.com/commercialhaskell/stack/issues/1892 for context. --- src/Stack/Build/Source.hs | 57 +++++++++++++++++++-------------------- src/Stack/PackageIndex.hs | 22 ++++++++++++--- 2 files changed, 45 insertions(+), 34 deletions(-) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index a987ca9d33..d26b81d5d9 100644 --- a/src/Stack/Build/Source.hs +++ b/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. diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 036ac721d6..b65412dbe8 100644 --- a/src/Stack/PackageIndex.hs +++ b/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