Commit 3aff0a5a authored by Duncan Coutts's avatar Duncan Coutts

Add cabal fetch --no-deps and --dry-run flags

Allows fetching one or more packages but without fetching their
dependencies and thus not requiring that a consistent install plan
can be found. On the other hand --no-deps means that there is no
guarantee that the fetched packages can actually be installed.
parent e6911efa
......@@ -41,14 +41,19 @@ import Distribution.Client.IndexUtils as IndexUtils
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.HttpUtils
( downloadURI, isOldHackageURI )
import Distribution.Client.Setup
( FetchFlags(..) )
import Distribution.Package
( PackageIdentifier, packageName, packageVersion, Dependency(..) )
( PackageIdentifier, packageId, packageName, packageVersion
, Dependency(..) )
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Simple.Compiler
( Compiler(compilerId), PackageDBStack )
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
( fromFlag )
import Distribution.Simple.Utils
( die, notice, info, debug, setupMessage )
import Distribution.System
......@@ -121,43 +126,48 @@ fetch :: Verbosity
-> [Repo]
-> Compiler
-> ProgramConfiguration
-> FetchFlags
-> [UnresolvedDependency]
-> IO ()
fetch verbosity _ _ _ _ [] =
fetch verbosity _ _ _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
fetch verbosity packageDBs repos comp conf deps = do
fetch verbosity packageDBs repos comp conf flags deps = do
installed <- getInstalledPackages verbosity comp packageDBs conf
availableDb@(AvailablePackageDb available _)
<- getAvailablePackages verbosity repos
deps' <- IndexUtils.disambiguateDependencies available deps
pkgs <- resolve verbosity
includeDependencies comp
pkgs <- resolvePackages verbosity
includeDeps comp
installed availableDb deps'
pkgs' <- filterM (fmap not . isFetched) pkgs
when (null pkgs') $
notice verbosity $ "No packages need to be fetched. "
++ "All the requested packages are already cached."
sequence_
[ fetchPackage verbosity repo pkgid
| (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- pkgs' ]
if dryRun
then notice verbosity $ unlines $
"The following packages would be fetched:"
: map (display . packageId) pkgs'
else sequence_
[ fetchPackage verbosity repo pkgid
| (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- pkgs' ]
where
--TODO: we want an explicit --no-deps flag, see ticket #423
includeDependencies = False
resolve :: Verbosity
-> Bool
-> Compiler
-> PackageIndex InstalledPackage
-> AvailablePackageDb
-> [UnresolvedDependency]
-> IO [AvailablePackage]
resolve verbosity includeDependencies comp
includeDeps = fromFlag (fetchDeps flags)
dryRun = fromFlag (fetchDryRun flags)
resolvePackages
:: Verbosity
-> Bool
-> Compiler
-> PackageIndex InstalledPackage
-> AvailablePackageDb
-> [UnresolvedDependency]
-> IO [AvailablePackage]
resolvePackages verbosity includeDependencies comp
installed (AvailablePackageDb available availablePrefs) deps
| includeDependencies = do
......@@ -169,6 +179,8 @@ resolve verbosity includeDependencies comp
installed' available
preferences constraints
targets
--TODO: suggest using --no-deps, unpack or fetch -o
-- if cannot satisfy deps
return (selectPackagesToFetch plan)
......
......@@ -20,7 +20,7 @@ module Distribution.Client.Setup
, updateCommand
, upgradeCommand
, infoCommand, InfoFlags(..)
, fetchCommand
, fetchCommand, FetchFlags(..)
, checkCommand
, uploadCommand, UploadFlags(..)
, reportCommand
......@@ -50,7 +50,7 @@ import Distribution.Simple.Setup
( ConfigFlags(..) )
import Distribution.Simple.Setup
( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe
, optionVerbosity, trueArg )
, optionVerbosity, trueArg, falseArg )
import Distribution.Simple.InstallDirs
( PathTemplate, toPathTemplate, fromPathTemplate )
import Distribution.Version
......@@ -278,19 +278,60 @@ instance Monoid ConfigExFlags where
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Other commands
-- * Fetch command
-- ------------------------------------------------------------
fetchCommand :: CommandUI (Flag Verbosity)
data FetchFlags = FetchFlags {
-- fetchOutput :: Flag FilePath,
fetchDeps :: Flag Bool,
fetchDryRun :: Flag Bool,
fetchVerbosity :: Flag Verbosity
}
defaultFetchFlags :: FetchFlags
defaultFetchFlags = FetchFlags {
-- fetchOutput = mempty,
fetchDeps = toFlag True,
fetchDryRun = toFlag False,
fetchVerbosity = toFlag normal
}
fetchCommand :: CommandUI FetchFlags
fetchCommand = CommandUI {
commandName = "fetch",
commandSynopsis = "Downloads packages for later installation.",
commandDescription = Nothing,
commandUsage = usagePackages "fetch",
commandDefaultFlags = toFlag normal,
commandOptions = \_ -> [optionVerbosity id const]
commandDefaultFlags = defaultFetchFlags,
commandOptions = \_ -> [
optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })
-- , option "o" ["output"]
-- "Put the package(s) somewhere specific rather than the usual cache."
-- fetchOutput (\v flags -> flags { fetchOutput = v })
-- (reqArgFlag "PATH")
, option [] ["dependencies", "deps"]
"Resolve and fetch dependencies (default)"
fetchDeps (\v flags -> flags { fetchDeps = v })
trueArg
, option [] ["no-dependencies", "no-deps"]
"Ignore dependencies"
fetchDeps (\v flags -> flags { fetchDeps = v })
falseArg
, option [] ["dry-run"]
"Do not install anything, only print what would be installed."
fetchDryRun (\v flags -> flags { fetchDryRun = v })
trueArg
]
}
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------
updateCommand :: CommandUI (Flag Verbosity)
updateCommand = CommandUI {
commandName = "update",
......
......@@ -19,7 +19,8 @@ import Distribution.Client.Setup
, ConfigExFlags(..), configureExCommand
, InstallFlags(..), defaultInstallFlags
, installCommand, upgradeCommand
, fetchCommand, checkCommand
, FetchFlags(..), fetchCommand
, checkCommand
, updateCommand
, ListFlags(..), listCommand
, InfoFlags(..), infoCommand
......@@ -267,17 +268,17 @@ upgradeAction (configFlags, configExFlags, installFlags)
[ UnresolvedDependency pkg (configConfigurationsFlags configFlags')
| pkg <- pkgs ]
fetchAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
fetchAction verbosityFlag extraArgs globalFlags = do
fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()
fetchAction fetchFlags extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlag verbosityFlag
let verbosity = fromFlag (fetchVerbosity fetchFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, conf) <- configCompilerAux configFlags
fetch verbosity
(configPackageDB' configFlags) (globalRepos globalFlags')
comp conf
comp conf fetchFlags
[ UnresolvedDependency pkg [] --TODO: flags?
| pkg <- pkgs ]
......
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