Commit a256df6d authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Make v2-freeze store index-state

parent 0fce6383
......@@ -12,6 +12,7 @@ import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectConfig
( ProjectConfig(..), ProjectConfigShared(..)
, writeProjectLocalFreezeConfig )
import Distribution.Client.IndexUtils (TotalIndexState)
import Distribution.Client.Targets
( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )
import Distribution.Solver.Types.PackageConstraint
......@@ -34,12 +35,12 @@ import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
import Distribution.Simple.Setup
( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )
import Distribution.Simple.Flag (Flag (..))
import Distribution.Simple.Utils
( die', notice, wrapText )
import Distribution.Verbosity
( normal )
import Data.Monoid as Monoid
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad (unless)
......@@ -119,13 +120,13 @@ freezeAction ( configFlags, configExFlags, installFlags
localPackages
} <- establishProjectBaseContext verbosity cliConfig OtherCommand
(_, elaboratedPlan, _) <-
(_, elaboratedPlan, _, totalIndexState) <-
rebuildInstallPlan verbosity
distDirLayout cabalDirLayout
projectConfig
localPackages
let freezeConfig = projectFreezeConfig elaboratedPlan
let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState
writeProjectLocalFreezeConfig distDirLayout freezeConfig
notice verbosity $
"Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"
......@@ -143,13 +144,13 @@ freezeAction ( configFlags, configExFlags, installFlags
-- | Given the install plan, produce a config value with constraints that
-- freezes the versions of packages used in the plan.
--
projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig
projectFreezeConfig elaboratedPlan =
Monoid.mempty {
projectConfigShared = Monoid.mempty {
projectConfigConstraints =
projectFreezeConfig :: ElaboratedInstallPlan -> TotalIndexState -> ProjectConfig
projectFreezeConfig elaboratedPlan totalIndexState = mempty
{ projectConfigShared = mempty
{ projectConfigConstraints =
concat (Map.elems (projectFreezeConstraints elaboratedPlan))
}
, projectConfigIndexState = Flag totalIndexState
}
}
-- | Given the install plan, produce solver constraints that will ensure the
......
......@@ -89,7 +89,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
let idxState :: Maybe TotalIndexState
idxState = flagToMaybe $ getIndexState getFlags
sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
(sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
......
......@@ -199,7 +199,7 @@ filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
-- This is a higher level wrapper used internally in cabal-install.
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages verbosity repoCtxt =
getSourcePackagesAtIndexState verbosity repoCtxt Nothing
fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing
-- | Variant of 'getSourcePackages' which allows getting the source
-- packages at a particular 'IndexState'.
......@@ -207,14 +207,14 @@ getSourcePackages verbosity repoCtxt =
-- Current choices are either the latest (aka HEAD), or the index as
-- it was at a particular time.
--
-- TODO: Enhance to allow specifying per-repo 'IndexState's and also
-- report back per-repo 'IndexStateInfo's (in order for @v2-freeze@
-- to access it)
-- Returns also the total index where repositories'
-- RepoIndexState's are not HEAD. This is used in v2-freeze.
--
getSourcePackagesAtIndexState
:: Verbosity
-> RepoContext
-> Maybe TotalIndexState
-> IO SourcePackageDb -- TODO: return TotalIndexState
-> IO (SourcePackageDb, TotalIndexState)
getSourcePackagesAtIndexState verbosity repoCtxt _
| null (repoContextRepos repoCtxt) = do
-- In the test suite, we routinely don't have any remote package
......@@ -222,21 +222,23 @@ getSourcePackagesAtIndexState verbosity repoCtxt _
warn (verboseUnmarkOutput verbosity) $
"No remote package servers have been specified. Usually " ++
"you would have one specified in the config file."
return SourcePackageDb {
return (SourcePackageDb {
packageIndex = mempty,
packagePreferences = mempty
}
}, headTotalIndexState)
getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
let describeState IndexStateHead = "most recent state"
describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do
let rname :: RepoName
rname = case r of
RepoRemote remote _ -> remoteRepoName remote
RepoSecure remote _ -> remoteRepoName remote
RepoLocalNoIndex local _ -> localRepoName local
RepoLocal _ -> RepoName "__local-repository" -- TODO...
let mrname :: Maybe RepoName
mrname = case r of
RepoRemote remote _ -> Just $ remoteRepoName remote
RepoSecure remote _ -> Just $ remoteRepoName remote
RepoLocalNoIndex local _ -> Just $ localRepoName local
RepoLocal _ -> Nothing
let rname = fromMaybe (RepoName "__local-repository") mrname
info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
......@@ -291,17 +293,40 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
prettyShow (isiMaxTime isi) ++ " (HEAD = " ++
prettyShow (isiHeadTime isi) ++ ")")
pure (pis,deps)
pure RepoData
{ rdIndexStates = maybe [] (\n -> [(n, isiMaxTime isi)]) mrname
, rdIndex = pis
, rdPreferences = deps
}
let (pkgs, prefs) = mconcat pkgss
let RepoData indexStates pkgs prefs = mconcat pkgss
prefs' = Map.fromListWith intersectVersionRanges
[ (name, range) | Dependency name range _ <- prefs ]
totalIndexState = foldl'
(\acc (rn, ts) -> insertIndexState rn (IndexStateTime ts) acc)
headTotalIndexState
indexStates
_ <- evaluate pkgs
_ <- evaluate prefs'
return SourcePackageDb {
_ <- evaluate totalIndexState
return (SourcePackageDb {
packageIndex = pkgs,
packagePreferences = prefs'
}
}, totalIndexState)
-- auxiliary data used in getSourcePackagesAtIndexState
data RepoData = RepoData
{ rdIndexStates :: [(RepoName, Timestamp)]
, rdIndex :: PackageIndex UnresolvedSourcePackage
, rdPreferences :: [Dependency]
}
instance Semigroup RepoData where
RepoData x y z <> RepoData u v w = RepoData (x <> u) (y <> v) (z <> w)
instance Monoid RepoData where
mempty = RepoData mempty mempty mempty
mappend = (<>)
readCacheStrict :: NFData pkg => Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])
readCacheStrict verbosity index mkPkg = do
......
......@@ -14,6 +14,7 @@ module Distribution.Client.IndexUtils.IndexState (
headTotalIndexState,
makeTotalIndexState,
lookupIndexState,
insertIndexState,
) where
import Distribution.Client.Compat.Prelude
......@@ -106,6 +107,12 @@ makeTotalIndexState def m = normalise (TIS def m)
lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState
lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m
-- | Insert a 'RepoIndexState' to 'TotalIndexState'.
insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState
insertIndexState rn idx (TIS def m)
| idx == def = TIS def (Map.delete rn m)
| otherwise = TIS def (Map.insert rn idx m)
-------------------------------------------------------------------------------
-- Repository index state
-------------------------------------------------------------------------------
......
......@@ -289,7 +289,7 @@ makeInstallContext verbosity
let idxState = flagToMaybe (installIndexState installFlags)
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
(sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
pkgConfigDb <- readPkgConfigDb verbosity progdb
checkConfigExFlags verbosity installedPkgIndex
......
......@@ -292,7 +292,7 @@ withInstallPlan
-- everything in the project. This is independent of any specific targets
-- the user has asked for.
--
(elaboratedPlan, _, elaboratedShared) <-
(elaboratedPlan, _, elaboratedShared, _) <-
rebuildInstallPlan verbosity
distDirLayout cabalDirLayout
projectConfig
......@@ -317,7 +317,7 @@ runProjectPreBuildPhase
-- everything in the project. This is independent of any specific targets
-- the user has asked for.
--
(elaboratedPlan, _, elaboratedShared) <-
(elaboratedPlan, _, elaboratedShared, _) <-
rebuildInstallPlan verbosity
distDirLayout cabalDirLayout
projectConfig
......
......@@ -396,7 +396,8 @@ rebuildInstallPlan :: Verbosity
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO ( ElaboratedInstallPlan -- with store packages
, ElaboratedInstallPlan -- with source packages
, ElaboratedSharedConfig )
, ElaboratedSharedConfig
, IndexUtils.TotalIndexState )
-- ^ @(improvedPlan, elaboratedPlan, _, _)@
rebuildInstallPlan verbosity
distDirLayout@DistDirLayout {
......@@ -417,14 +418,14 @@ rebuildInstallPlan verbosity
(projectConfigMonitored, localPackages, progsearchpath) $ do
-- And so is the elaborated plan that the improved plan based on
(elaboratedPlan, elaboratedShared) <-
(elaboratedPlan, elaboratedShared, totalIndexState) <-
rerunIfChanged verbosity fileMonitorElaboratedPlan
(projectConfigMonitored, localPackages,
progsearchpath) $ do
compilerEtc <- phaseConfigureCompiler projectConfig
_ <- phaseConfigurePrograms projectConfig compilerEtc
(solverPlan, pkgConfigDB)
(solverPlan, pkgConfigDB, totalIndexState)
<- phaseRunSolver projectConfig
compilerEtc
localPackages
......@@ -435,14 +436,14 @@ rebuildInstallPlan verbosity
localPackages
phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
return (elaboratedPlan, elaboratedShared)
return (elaboratedPlan, elaboratedShared, totalIndexState)
-- The improved plan changes each time we install something, whereas
-- the underlying elaborated plan only changes when input config
-- changes, so it's worth caching them separately.
improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
return (improvedPlan, elaboratedPlan, elaboratedShared)
return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState)
where
fileMonitorCompiler = newFileMonitorInCacheDir "compiler"
......@@ -543,10 +544,11 @@ rebuildInstallPlan verbosity
-- Run the solver to get the initial install plan.
-- This is expensive so we cache it independently.
--
phaseRunSolver :: ProjectConfig
-> (Compiler, Platform, ProgramDb)
-> [PackageSpecifier UnresolvedSourcePackage]
-> Rebuild (SolverInstallPlan, PkgConfigDb)
phaseRunSolver
:: ProjectConfig
-> (Compiler, Platform, ProgramDb)
-> [PackageSpecifier UnresolvedSourcePackage]
-> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState)
phaseRunSolver projectConfig@ProjectConfig {
projectConfigShared,
projectConfigBuildOnly
......@@ -561,7 +563,7 @@ rebuildInstallPlan verbosity
installedPkgIndex <- getInstalledPackages verbosity
compiler progdb platform
corePackageDbs
sourcePkgDb <- getSourcePackages verbosity withRepoCtx
(sourcePkgDb, tis)<- getSourcePackages verbosity withRepoCtx
(solverSettingIndexState solverSettings)
pkgConfigDB <- getPkgConfigDb verbosity progdb
......@@ -580,7 +582,7 @@ rebuildInstallPlan verbosity
planPackages verbosity compiler platform solver solverSettings
installedPkgIndex sourcePkgDb pkgConfigDB
localPackages localPackagesEnabledStanzas
return (plan, pkgConfigDB)
return (plan, pkgConfigDB, tis)
where
corePackageDbs = [GlobalPackageDB]
withRepoCtx = projectConfigWithSolverRepoContext verbosity
......@@ -757,20 +759,23 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do
packagedb progdb
-}
getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
-> Maybe IndexUtils.TotalIndexState -> Rebuild SourcePackageDb
getSourcePackages
:: Verbosity
-> (forall a. (RepoContext -> IO a) -> IO a)
-> Maybe IndexUtils.TotalIndexState
-> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState)
getSourcePackages verbosity withRepoCtx idxState = do
(sourcePkgDb, repos) <-
(sourcePkgDbWithTIS, repos) <-
liftIO $
withRepoCtx $ \repoctx -> do
sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity
sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity
repoctx idxState
return (sourcePkgDb, repoContextRepos repoctx)
return (sourcePkgDbWithTIS, repoContextRepos repoctx)
mapM_ needIfExists
. IndexUtils.getSourcePackagesMonitorFiles
$ repos
return sourcePkgDb
return sourcePkgDbWithTIS
getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb
......
......@@ -1541,7 +1541,7 @@ planProject testdir cliConfig = do
localPackages,
_buildSettings) <- configureProject testdir cliConfig
(elaboratedPlan, _, elaboratedShared) <-
(elaboratedPlan, _, elaboratedShared, _) <-
rebuildInstallPlan verbosity
distDirLayout cabalDirLayout
projectConfig
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment