Commit abd2fa6a authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Hook up `--index-state` to `install` flags in CLI

parent e0b393e5
......@@ -249,6 +249,7 @@ instance Semigroup SavedConfig where
installUpgradeDeps = combine installUpgradeDeps,
installOnly = combine installOnly,
installOnlyDeps = combine installOnlyDeps,
installIndexState = combine installIndexState,
installRootCmd = combine installRootCmd,
installSummaryFile = lastNonEmptyNL installSummaryFile,
installLogFile = combine installLogFile,
......
......@@ -80,7 +80,7 @@ import Distribution.Client.HttpUtils
import Distribution.Solver.Types.PackageFixedDeps
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
( getSourcePackagesAtIndexState, IndexState(..), getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
......@@ -277,10 +277,13 @@ makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
-> IO InstallContext
makeInstallContext verbosity
(packageDBs, repoCtxt, comp, _, progdb,_,_,
globalFlags, _, configExFlags, _, _) mUserTargets = do
globalFlags, _, configExFlags, installFlags, _) mUserTargets = do
let idxState = fromFlagOrDefault IndexStateHead $
installIndexState installFlags
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
sourcePkgDb <- getSourcePackages verbosity repoCtxt
sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
pkgConfigDb <- readPkgConfigDb verbosity progdb
checkConfigExFlags verbosity installedPkgIndex
......
......@@ -58,6 +58,8 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Config
( loadConfig, defaultConfigFile )
import Distribution.Client.IndexUtils.Timestamp
( IndexState(..) )
import Distribution.Solver.Types.SourcePackage
import Distribution.Solver.Types.Settings
......@@ -202,6 +204,7 @@ resolveSolverSettings ProjectConfig{
solverSettingReorderGoals = fromFlag projectConfigReorderGoals
solverSettingCountConflicts = fromFlag projectConfigCountConflicts
solverSettingStrongFlags = fromFlag projectConfigStrongFlags
solverSettingIndexState = fromFlagOrDefault IndexStateHead projectConfigIndexState
--solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals
--solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs
--solverSettingReinstall = fromFlag projectConfigReinstall
......
......@@ -302,6 +302,7 @@ convertLegacyAllPackageFlags globalFlags configFlags
--installReinstall = projectConfigReinstall,
--installAvoidReinstalls = projectConfigAvoidReinstalls,
--installOverrideReinstall = projectConfigOverrideReinstall,
installIndexState = projectConfigIndexState,
installMaxBackjumps = projectConfigMaxBackjumps,
--installUpgradeDeps = projectConfigUpgradeDeps,
installReorderGoals = projectConfigReorderGoals,
......@@ -505,6 +506,7 @@ convertToLegacySharedConfig
installStrongFlags = projectConfigStrongFlags,
installOnly = mempty,
installOnlyDeps = projectConfigOnlyDeps,
installIndexState = projectConfigIndexState,
installRootCmd = mempty, --no longer supported
installSummaryFile = projectConfigSummaryFile,
installLogFile = projectConfigLogFile,
......@@ -848,6 +850,7 @@ legacySharedConfigFieldDescrs =
, "one-shot", "jobs", "keep-going", "offline"
-- solver flags:
, "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags"
, "index-state"
]
. commandOptionsToFields
) (installOptions ParseArgs)
......
......@@ -29,6 +29,9 @@ import Distribution.Client.Targets
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.IndexUtils.Timestamp
( IndexState )
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.ConstraintSource
......@@ -164,6 +167,7 @@ data ProjectConfigShared
-- configuration used both by the solver and other phases
projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers.
projectConfigLocalRepos :: NubList FilePath,
projectConfigIndexState :: Flag IndexState,
-- solver configuration
projectConfigConstraints :: [(UserConstraint, ConstraintSource)],
......@@ -347,7 +351,8 @@ data SolverSettings
solverSettingMaxBackjumps :: Maybe Int,
solverSettingReorderGoals :: ReorderGoals,
solverSettingCountConflicts :: CountConflicts,
solverSettingStrongFlags :: StrongFlags
solverSettingStrongFlags :: StrongFlags,
solverSettingIndexState :: IndexState
-- Things that only make sense for manual mode, not --local mode
-- too much control!
--solverSettingIndependentGoals :: Bool,
......
......@@ -480,8 +480,9 @@ rebuildInstallPlan verbosity
installedPkgIndex <- getInstalledPackages verbosity
compiler progdb platform
corePackageDbs
sourcePkgDb <- getSourcePackages verbosity withRepoCtx
pkgConfigDB <- getPkgConfigDb verbosity progdb
sourcePkgDb <- getSourcePackages verbosity withRepoCtx
(solverSettingIndexState solverSettings)
pkgConfigDB <- getPkgConfigDb verbosity progdb
--TODO: [code cleanup] it'd be better if the Compiler contained the
-- ConfiguredPrograms that it needs, rather than relying on the progdb
......@@ -688,12 +689,13 @@ getExecutableDBContents storeDirectory = do
valid _ = True
getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
-> Rebuild SourcePackageDb
getSourcePackages verbosity withRepoCtx = do
-> IndexUtils.IndexState -> Rebuild SourcePackageDb
getSourcePackages verbosity withRepoCtx idxState = do
(sourcePkgDb, repos) <-
liftIO $
withRepoCtx $ \repoctx -> do
sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoctx
sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity
repoctx idxState
return (sourcePkgDb, repoContextRepos repoctx)
monitorFiles . map monitorFile
......
......@@ -61,6 +61,10 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
( PreSolver(..) )
import Distribution.Client.IndexUtils.Timestamp
( IndexState )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
import Distribution.Client.Targets
......@@ -1219,6 +1223,7 @@ data InstallFlags = InstallFlags {
installUpgradeDeps :: Flag Bool,
installOnly :: Flag Bool,
installOnlyDeps :: Flag Bool,
installIndexState :: Flag IndexState,
installRootCmd :: Flag String,
installSummaryFile :: NubList PathTemplate,
installLogFile :: Flag PathTemplate,
......@@ -1252,6 +1257,7 @@ defaultInstallFlags = InstallFlags {
installUpgradeDeps = Flag False,
installOnly = Flag False,
installOnlyDeps = Flag False,
installIndexState = mempty,
installRootCmd = mempty,
installSummaryFile = mempty,
installLogFile = mempty,
......@@ -1424,6 +1430,18 @@ installOptions showOrParseArgs =
installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
(yesNoOpt showOrParseArgs)
, option [] ["index-state"]
("Use source package index state as it existed at a previous time. " ++
"Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++
"(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")
installIndexState (\v flags -> flags { installIndexState = v })
(reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++
"unix-timestamps (e.g. '@1474732068'), " ++
"a ISO8601 UTC timestamp " ++
"(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")
(toFlag `fmap` parse))
(flagToList . fmap display))
, option [] ["root-cmd"]
"(No longer supported, do not use.)"
installRootCmd (\v flags -> flags { installRootCmd = v })
......
......@@ -30,6 +30,8 @@ import Distribution.Simple.InstallDirs
import Distribution.Utils.NubList
import Distribution.Client.IndexUtils.Timestamp
import Test.QuickCheck
......@@ -172,3 +174,10 @@ instance Arbitrary a => Arbitrary (NoShrink a) where
arbitrary = NoShrink <$> arbitrary
shrink _ = []
instance Arbitrary Timestamp where
arbitrary = (maybe (toEnum 0) id . epochTimeToTimestamp) <$> arbitrary
instance Arbitrary IndexState where
arbitrary = frequency [ (1, pure IndexStateHead)
, (50, IndexStateTime <$> arbitrary)
]
......@@ -344,6 +344,7 @@ instance Arbitrary ProjectConfigShared where
<*> arbitrary
<*> arbitrary
<*> (toNubList <$> listOf arbitraryShortToken)
<*> arbitrary
<*> arbitraryConstraints
<*> shortListOf 2 arbitrary
<*> arbitrary <*> arbitrary
......@@ -358,19 +359,21 @@ instance Arbitrary ProjectConfigShared where
shrink (ProjectConfigShared
x00 x01 x02 x03 x04
x05 x06 x07 x08 x09
x10 x11 x12 x13 x14 x15) =
x10 x11 x12 x13 x14
x15 x16) =
[ ProjectConfigShared
x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04'
x05' (postShrink_Constraints x06') x07' x08' x09'
x10' x11' x12' x13' x14' x15'
x05' x06' (postShrink_Constraints x07') x08' x09'
x10' x11' x12' x13' x14' x15' x16'
| ((x00', x01', x02', x03', x04'),
(x05', x06', x07', x08', x09'),
(x10', x11', x12', x13', x14'),
x15')
(x15', x16'))
<- shrink
((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04),
(x05, preShrink_Constraints x06, x07, x08, x09),
(x10, x11, x12, x13, x14), x15)
(x05, x06, preShrink_Constraints x07, x08, x09),
(x10, x11, x12, x13, x14),
(x15, x16))
]
where
preShrink_Constraints = map fst
......
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