Commit 57870fcc authored by Oleg Grenrus's avatar Oleg Grenrus

Add ActiveRepos data type, add active-repositories config

parent 10051c3c
......@@ -50,7 +50,7 @@ data GrammarRegex a
| RESpaces -- ^ zero-or-more spaces
| RESpaces1 -- ^ one-or-more spaces
| RECommaList (GrammarRegex a) -- ^ comma list (note, leading or trailing commas)
| RECommaNonEmpty (GrammarRegex a) -- ^ comma non-empty list
| RECommaNonEmpty (GrammarRegex a) -- ^ comma non-empty list (note, leading or trailing commas)
| REOptCommaList (GrammarRegex a) -- ^ opt comma list
| RETodo -- ^ unspecified
......
......@@ -251,6 +251,7 @@ instance Semigroup SavedConfig where
globalRemoteRepos = lastNonEmptyNL globalRemoteRepos,
globalCacheDir = combine globalCacheDir,
globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos,
globalActiveRepos = combine globalActiveRepos,
globalLogsDir = combine globalLogsDir,
globalWorldFile = combine globalWorldFile,
globalIgnoreExpiry = combine globalIgnoreExpiry,
......
......@@ -51,8 +51,8 @@ import Distribution.Client.Dependency
import Distribution.Client.VCS
import Distribution.Client.FetchUtils
import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackagesAtIndexState, TotalIndexState )
import Distribution.Client.IndexUtils
( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos )
import Distribution.Solver.Types.SourcePackage
import Control.Exception
......@@ -89,7 +89,10 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
let idxState :: Maybe TotalIndexState
idxState = flagToMaybe $ getIndexState getFlags
(sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
activeRepos :: Maybe ActiveRepos
activeRepos = flagToMaybe $ getActiveRepos getFlags
(sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
......
......@@ -29,6 +29,9 @@ import Distribution.Verbosity
import Distribution.Simple.Utils
( info, warn )
import Distribution.Client.IndexUtils.ActiveRepos
( ActiveRepos )
import Control.Concurrent
( MVar, newMVar, modifyMVar )
import Control.Exception
......@@ -55,47 +58,50 @@ import qualified System.FilePath.Posix as FilePath.Posix
-- ------------------------------------------------------------
-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
globalVersion :: Flag Bool,
globalNumericVersion :: Flag Bool,
globalConfigFile :: Flag FilePath,
globalConstraintsFile :: Flag FilePath,
globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers.
globalCacheDir :: Flag FilePath,
globalLocalNoIndexRepos :: NubList LocalRepo,
globalLogsDir :: Flag FilePath,
globalWorldFile :: Flag FilePath,
globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates
globalHttpTransport :: Flag String,
globalNix :: Flag Bool, -- ^ Integrate with Nix
globalStoreDir :: Flag FilePath,
globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)
} deriving Generic
data GlobalFlags = GlobalFlags
{ globalVersion :: Flag Bool
, globalNumericVersion :: Flag Bool
, globalConfigFile :: Flag FilePath
, globalConstraintsFile :: Flag FilePath
, globalRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers.
, globalCacheDir :: Flag FilePath
, globalLocalNoIndexRepos :: NubList LocalRepo
, globalActiveRepos :: Flag ActiveRepos
, globalLogsDir :: Flag FilePath
, globalWorldFile :: Flag FilePath
, globalIgnoreExpiry :: Flag Bool -- ^ Ignore security expiry dates
, globalHttpTransport :: Flag String
, globalNix :: Flag Bool -- ^ Integrate with Nix
, globalStoreDir :: Flag FilePath
, globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)
} deriving Generic
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags = GlobalFlags {
globalVersion = Flag False,
globalNumericVersion = Flag False,
globalConfigFile = mempty,
globalConstraintsFile = mempty,
globalRemoteRepos = mempty,
globalCacheDir = mempty,
globalLocalNoIndexRepos = mempty,
globalLogsDir = mempty,
globalWorldFile = mempty,
globalIgnoreExpiry = Flag False,
globalHttpTransport = mempty,
globalNix = Flag False,
globalStoreDir = mempty,
globalProgPathExtra = mempty
}
defaultGlobalFlags = GlobalFlags
{ globalVersion = Flag False
, globalNumericVersion = Flag False
, globalConfigFile = mempty
, globalConstraintsFile = mempty
, globalRemoteRepos = mempty
, globalCacheDir = mempty
, globalLocalNoIndexRepos = mempty
, globalActiveRepos = mempty
, globalLogsDir = mempty
, globalWorldFile = mempty
, globalIgnoreExpiry = Flag False
, globalHttpTransport = mempty
, globalNix = Flag False
, globalStoreDir = mempty
, globalProgPathExtra = mempty
}
instance Monoid GlobalFlags where
mempty = gmempty
mappend = (<>)
mempty = gmempty
mappend = (<>)
instance Semigroup GlobalFlags where
(<>) = gmappend
(<>) = gmappend
-- ------------------------------------------------------------
-- * Repo context
......
......@@ -28,6 +28,7 @@ module Distribution.Client.IndexUtils (
TotalIndexState,
getSourcePackagesAtIndexState,
ActiveRepos,
Index(..),
RepoIndexState (..),
......@@ -48,6 +49,7 @@ import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Archive.Tar.Index as Tar
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.IndexUtils.ActiveRepos
import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.Types
......@@ -69,8 +71,9 @@ import Distribution.Simple.Program
( ProgramDb )
import qualified Distribution.Simple.Configure as Configure
( getInstalledPackages, getInstalledPackagesMonitorFiles )
import Distribution.Types.PackageName (PackageName)
import Distribution.Version
( Version, mkVersion, intersectVersionRanges )
( Version, VersionRange, mkVersion, intersectVersionRanges )
import Distribution.Deprecated.Text
( display, simpleParse )
import Distribution.Simple.Utils
......@@ -197,7 +200,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 =
fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing
fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
-- | Variant of 'getSourcePackages' which allows getting the source
-- packages at a particular 'IndexState'.
......@@ -212,8 +215,9 @@ getSourcePackagesAtIndexState
:: Verbosity
-> RepoContext
-> Maybe TotalIndexState
-> Maybe ActiveRepos
-> IO (SourcePackageDb, TotalIndexState)
getSourcePackagesAtIndexState verbosity repoCtxt _
getSourcePackagesAtIndexState verbosity repoCtxt _ _
| null (repoContextRepos repoCtxt) = do
-- In the test suite, we routinely don't have any remote package
-- servers, so don't bleat about it
......@@ -224,7 +228,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt _
packageIndex = mempty,
packagePreferences = mempty
}, headTotalIndexState)
getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
let describeState IndexStateHead = "most recent state"
describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
......@@ -288,40 +292,59 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
prettyShow (isiHeadTime isi) ++ ")")
pure RepoData
{ rdIndexStates = [(rname, isiMaxTime isi)]
{ rdRepoName = rname
, rdTimeStamp = isiMaxTime isi
, rdIndex = pis
, rdPreferences = deps
}
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
let activeRepos :: ActiveRepos
activeRepos = fromMaybe defaultActiveRepos mb_activeRepos
pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of
Right x -> return x
Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)
let totalIndexState :: TotalIndexState
totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList
[ (n, IndexStateTime ts)
| (RepoData n ts _idx _prefs, _strategy) <- pkgss'
]
let addIndex
:: PackageIndex UnresolvedSourcePackage
-> (RepoData, CombineStrategy)
-> PackageIndex UnresolvedSourcePackage
addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx
addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx
let pkgs :: PackageIndex UnresolvedSourcePackage
pkgs = foldl' addIndex mempty pkgss'
-- Note: preferences combined without using CombineStrategy
let prefs :: Map PackageName VersionRange
prefs = Map.fromListWith intersectVersionRanges
[ (name, range)
| (RepoData _n _ts _idx prefs', _strategy) <- pkgss'
, Dependency name range _ <- prefs'
]
_ <- evaluate pkgs
_ <- evaluate prefs'
_ <- evaluate prefs
_ <- evaluate totalIndexState
return (SourcePackageDb {
packageIndex = pkgs,
packagePreferences = prefs'
packagePreferences = prefs
}, totalIndexState)
-- auxiliary data used in getSourcePackagesAtIndexState
data RepoData = RepoData
{ rdIndexStates :: [(RepoName, Timestamp)]
{ rdRepoName :: RepoName
, rdTimeStamp :: 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 = (<>)
-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
--
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Client.IndexUtils.ActiveRepos (
ActiveRepos (..),
defaultActiveRepos,
ActiveRepoEntry (..),
CombineStrategy (..),
organizeByRepos,
) where
import Distribution.Client.Compat.Prelude
import Distribution.Client.Types.RepoName (RepoName (..))
import Prelude ()
import Distribution.FieldGrammar.Described
import Distribution.Parsec (Parsec (..), parsecLeadingCommaList)
import Distribution.Pretty (Pretty (..), prettyShow)
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-- $setup
-- >>> import Distribution.Parsec
-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------
-- | Ordered list of active repositories.
newtype ActiveRepos = ActiveRepos [ActiveRepoEntry]
deriving (Eq, Show, Generic)
defaultActiveRepos :: ActiveRepos
defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ]
instance Binary ActiveRepos
instance Structured ActiveRepos
instance NFData ActiveRepos
instance Pretty ActiveRepos where
pretty (ActiveRepos [])
= Disp.text ":none"
pretty (ActiveRepos repos)
= Disp.hsep
$ Disp.punctuate Disp.comma
$ map pretty repos
-- | Note: empty string is not valid 'ActiveRepos'.
--
-- >>> simpleParsec "" :: Maybe ActiveRepos
-- Nothing
--
-- >>> simpleParsec ":none" :: Maybe ActiveRepos
-- Just (ActiveRepos [])
--
-- >>> simpleParsec ":rest" :: Maybe ActiveRepos
-- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge])
--
-- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos
-- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride])
--
instance Parsec ActiveRepos where
parsec = ActiveRepos [] <$ P.try (P.string ":none")
<|> do
repos <- parsecLeadingCommaList parsec
return (ActiveRepos (toList repos))
instance Described ActiveRepos where
describe _ = REUnion
[ ":none"
, RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry))
]
data ActiveRepoEntry
= ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo'
| ActiveRepo RepoName CombineStrategy -- ^ explicit repository name
deriving (Eq, Show, Generic)
instance Binary ActiveRepoEntry
instance Structured ActiveRepoEntry
instance NFData ActiveRepoEntry
instance Pretty ActiveRepoEntry where
pretty (ActiveRepoRest s) =
Disp.text ":rest" <<>> Disp.colon <<>> pretty s
pretty (ActiveRepo r s) =
pretty r <<>> Disp.colon <<>> pretty s
instance Parsec ActiveRepoEntry where
parsec = leadColon <|> leadRepo where
leadColon = do
_ <- P.char ':'
token <- P.munch1 isAlpha
case token of
"rest" -> ActiveRepoRest <$> strategyP
"repo" -> P.char ':' *> leadRepo
_ -> P.unexpected $ "Unknown active repository entry type: " ++ token
leadRepo = do
r <- parsec
s <- strategyP
return (ActiveRepo r s)
strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec)
instance Described ActiveRepoEntry where
describe _ = REUnion
[ ":rest" <> strategy
, REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy
]
where
strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy)
data CombineStrategy
= CombineStrategyMerge -- ^ merge existing versions
| CombineStrategyOverride -- ^ if later repository specifies a package,
-- all package versions are replaced
deriving (Eq, Show, Enum, Bounded, Generic)
instance Binary CombineStrategy
instance Structured CombineStrategy
instance NFData CombineStrategy
instance Pretty CombineStrategy where
pretty CombineStrategyMerge = Disp.text "merge"
pretty CombineStrategyOverride = Disp.text "override"
instance Parsec CombineStrategy where
parsec = P.choice
[ CombineStrategyMerge <$ P.string "merge"
, CombineStrategyOverride <$ P.string "override"
]
instance Described CombineStrategy where
describe _ = REUnion
[ "merge"
, "override"
]
-------------------------------------------------------------------------------
-- Organisation
-------------------------------------------------------------------------------
-- | Sort values 'RepoName' according to 'ActiveRepos' list.
--
-- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"]
-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos
-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]
--
-- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos
-- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]
--
-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos
-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)]
--
-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos
-- Left "no repository provided d"
--
-- Note: currently if 'ActiveRepoRest' is provided more than once,
-- rest-repositories will be multiple times in the output.
--
organizeByRepos
:: forall a. ActiveRepos
-> (a -> RepoName)
-> [a]
-> Either String [(a, CombineStrategy)]
organizeByRepos (ActiveRepos xs0) sel ys0 =
-- here we use lazyness to do only one traversal
let (rest, result) = case go rest xs0 ys0 of
Right (rest', result') -> (rest', Right result')
Left err -> ([], Left err)
in result
where
go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)])
go _rest [] ys = Right (ys, [])
go rest (ActiveRepoRest s : xs) ys =
go rest xs ys <&> \(rest', result) ->
(rest', map (\x -> (x, s)) rest ++ result)
go rest (ActiveRepo r s : xs) ys = do
(z, zs) <- extract r ys
go rest xs zs <&> \(rest', result) ->
(rest', (z, s) : result)
extract :: RepoName -> [a] -> Either String (a, [a])
extract r = loop id where
loop _acc [] = Left $ "no repository provided " ++ prettyShow r
loop acc (x:xs)
| sel x == r = Right (x, acc xs)
| otherwise = loop (acc . (x :)) xs
(<&>)
:: Either err ([s], b)
-> (([s], b) -> ([s], c))
-> Either err ([s], c)
(<&>) = flip fmap
......@@ -272,7 +272,7 @@ makeInstallContext verbosity
let idxState = flagToMaybe (installIndexState installFlags)
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
(sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
(sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing
pkgConfigDb <- readPkgConfigDb verbosity progdb
checkConfigExFlags verbosity installedPkgIndex
......
......@@ -253,6 +253,7 @@ resolveSolverSettings ProjectConfig{
solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls
solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained
solverSettingIndexState = flagToMaybe projectConfigIndexState
solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos
solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals
--solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs
--solverSettingReinstall = fromFlag projectConfigReinstall
......
......@@ -335,6 +335,7 @@ convertLegacyAllPackageFlags globalFlags configFlags
globalConfigFile = projectConfigConfigFile,
globalRemoteRepos = projectConfigRemoteRepos,
globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,
globalActiveRepos = projectConfigActiveRepos,
globalProgPathExtra = projectConfigProgPathExtra,
globalStoreDir = projectConfigStoreDir
} = globalFlags
......@@ -569,6 +570,7 @@ convertToLegacySharedConfig
globalRemoteRepos = projectConfigRemoteRepos,
globalCacheDir = projectConfigCacheDir,
globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,
globalActiveRepos = projectConfigActiveRepos,
globalLogsDir = projectConfigLogsDir,
globalWorldFile = mempty,
globalIgnoreExpiry = projectConfigIgnoreExpiry,
......@@ -939,6 +941,7 @@ legacySharedConfigFieldDescrs =
. filterFields
[ "remote-repo-cache"
, "logs-dir", "store-dir", "ignore-expiry", "http-transport"
, "active-repositories"
]
. commandOptionsToFields
) (commandOptions (globalCommand []) ParseArgs)
......
......@@ -36,6 +36,8 @@ import Distribution.Client.Types.SourceRepo (SourceRepoList)
import Distribution.Client.IndexUtils.IndexState
( TotalIndexState )
import Distribution.Client.IndexUtils.ActiveRepos
( ActiveRepos )
import Distribution.Client.CmdInstall.ClientInstallFlags
( ClientInstallFlags(..) )
......@@ -180,6 +182,7 @@ data ProjectConfigShared
-- configuration used both by the solver and other phases
projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers.
projectConfigLocalNoIndexRepos :: NubList LocalRepo,
projectConfigActiveRepos :: Flag ActiveRepos,
projectConfigIndexState :: Flag TotalIndexState,
projectConfigStoreDir :: Flag FilePath,
......@@ -406,6 +409,7 @@ data SolverSettings
solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,
solverSettingOnlyConstrained :: OnlyConstrained,
solverSettingIndexState :: Maybe TotalIndexState,
solverSettingActiveRepos :: Maybe ActiveRepos,
solverSettingIndependentGoals :: IndependentGoals
-- Things that only make sense for manual mode, not --local mode
-- too much control!
......
......@@ -566,6 +566,7 @@ rebuildInstallPlan verbosity
corePackageDbs
(sourcePkgDb, tis)<- getSourcePackages verbosity withRepoCtx
(solverSettingIndexState solverSettings)
(solverSettingActiveRepos solverSettings)
pkgConfigDB <- getPkgConfigDb verbosity progdb
--TODO: [code cleanup] it'd be better if the Compiler contained the
......@@ -764,13 +765,13 @@ getSourcePackages
:: Verbosity
-> (forall a. (RepoContext -> IO a) -> IO a)
-> Maybe IndexUtils.TotalIndexState
-> Maybe IndexUtils.ActiveRepos
-> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState)
getSourcePackages verbosity withRepoCtx idxState = do
getSourcePackages verbosity withRepoCtx idxState activeRepos = do
(sourcePkgDbWithTIS, repos) <-
liftIO $
withRepoCtx $ \repoctx -> do
sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity
repoctx idxState
sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos
return (sourcePkgDbWithTIS, repoContextRepos repoctx)
mapM_ needIfExists
......
......@@ -71,6 +71,8 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
( PreSolver(..) )
import Distribution.Client.IndexUtils.ActiveRepos
( ActiveRepos )
import Distribution.Client.IndexUtils.IndexState
( TotalIndexState, headTotalIndexState )
import qualified Distribution.Client.Init.Types as IT
......@@ -388,6 +390,7 @@ globalCommand commands = CommandUI {
"Nix integration: run commands through nix-shell if a 'shell.nix' file exists"
globalNix (\v flags -> flags { globalNix = v })
(boolOpt [] [])
]
-- arguments we don't want shown in the help
......@@ -422,6 +425,13 @@ globalCommand commands = CommandUI {
"The location of the nix-local-build store"
globalStoreDir (\v flags -> flags { globalStoreDir = v })
(reqArgFlag "DIR")
, option [] ["active-repositories"]
"The active package repositories"
globalActiveRepos (\v flags -> flags { globalActiveRepos = v })
(reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err)
(toFlag `fmap` parsec))
(map prettyShow . flagToList))
]
-- ------------------------------------------------------------
......@@ -1430,6 +1440,7 @@ data GetFlags = GetFlags {
getDestDir :: Flag FilePath,
getPristine :: Flag Bool,
getIndexState :: Flag TotalIndexState,
getActiveRepos :: Flag ActiveRepos,
getSourceRepository :: Flag (Maybe RepoKind),
getVerbosity :: Flag Verbosity
} deriving Generic
......@@ -1439,6 +1450,7 @@ defaultGetFlags = GetFlags {
getDestDir = mempty,
getPristine = mempty,
getIndexState = mempty,
getActiveRepos = mempty,
getSourceRepository = mempty,
getVerbosity = toFlag normal
}
......
......@@ -21,6 +21,7 @@ module Distribution.Solver.Types.PackageIndex (
-- * Updates
merge,
override,
insert,
deletePackageName,
deletePackageId,
......@@ -159,6 +160,7 @@ merge i1@(PackageIndex m1) i2@(PackageIndex m2) =
assert (invariant i1 && invariant i2) $
mkPackageIndex (Map.unionWith mergeBuckets m1 m2)
-- | Elements in the second list mask those in the first.
mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]
mergeBuckets [] ys = ys
......@@ -169,6 +171,16 @@ mergeBuckets xs@(x:xs') ys@(y:ys') =
EQ -> y : mergeBuckets xs' ys'