Commit c76d7fc3 authored by Lennart Kolmodin's avatar Lennart Kolmodin

Implement --dry-run for 'cabal install'

parent fd5a1560
......@@ -25,6 +25,7 @@ import Hackage.Dependency (resolveDependencies, resolveDependenciesLocal, packag
import Hackage.Fetch (fetchPackage)
import qualified Hackage.IndexUtils as IndexUtils
import qualified Hackage.DepGraph as DepGraph
import Hackage.Setup (InstallFlags(..))
import Hackage.Tar (extractTarGzFile)
import Hackage.Types (UnresolvedDependency(..), PkgInfo(..), FlagAssignment,
Repo)
......@@ -57,12 +58,14 @@ install :: Verbosity
-> Compiler
-> ProgramConfiguration
-> Cabal.ConfigFlags
-> InstallFlags
-> [UnresolvedDependency]
-> IO ()
install verbosity packageDB repos comp conf configFlags deps = do
install verbosity packageDB repos comp conf configFlags installFlags deps = do
let dryRun = Cabal.fromFlagOrDefault False (installDryRun installFlags)
buildResults <- if null deps
then installLocalPackage verbosity packageDB repos comp conf configFlags
else installRepoPackages verbosity packageDB repos comp conf configFlags deps
then installLocalPackage verbosity packageDB repos comp conf configFlags dryRun
else installRepoPackages verbosity packageDB repos comp conf configFlags dryRun deps
case filter (buildFailed . snd) buildResults of
[] -> return () --TODO: return the build results
failed -> die $ "Error: some packages failed to install:\n"
......@@ -87,8 +90,9 @@ installLocalPackage :: Verbosity
-> Compiler
-> ProgramConfiguration
-> Cabal.ConfigFlags
-> Bool -- ^Dry run
-> IO [(PackageIdentifier, BuildResult)]
installLocalPackage verbosity packageDB repos comp conf configFlags =
installLocalPackage verbosity packageDB repos comp conf configFlags dryRun =
do cabalFile <- defaultPackageDesc verbosity
desc <- readPackageDescription verbosity cabalFile
Just installed <- getInstalledPackages verbosity comp packageDB conf
......@@ -97,10 +101,15 @@ installLocalPackage verbosity packageDB repos comp conf configFlags =
(Cabal.configConfigurationsFlags configFlags)
buildResults <- case packagesToInstall resolvedDeps of
Left missing -> die $ "Unresolved dependencies: " ++ showDependencies missing
Right pkgs -> installPackages verbosity configFlags pkgs
--TODO: don't run if buildResult failed
buildResult <- installUnpackedPkg verbosity configFlags Nothing
return ((packageId (packageDescription desc), buildResult) : buildResults)
Right pkgs -> do
if dryRun
then printDryRun pkgs >> return []
else installPackages verbosity configFlags pkgs
if dryRun
then return []
--TODO: don't run if buildResult failed
else do buildResult <- installUnpackedPkg verbosity configFlags Nothing
return ((packageId (packageDescription desc), buildResult) : buildResults)
installRepoPackages :: Verbosity
-> PackageDB
......@@ -108,9 +117,10 @@ installRepoPackages :: Verbosity
-> Compiler
-> ProgramConfiguration
-> Cabal.ConfigFlags
-> Bool -- ^Dry run
-> [UnresolvedDependency]
-> IO [(PackageIdentifier, BuildResult)]
installRepoPackages verbosity packageDB repos comp conf configFlags deps =
installRepoPackages verbosity packageDB repos comp conf configFlags dryRun deps =
do Just installed <- getInstalledPackages verbosity comp packageDB conf
available <- fmap mconcat (mapM (IndexUtils.readRepoIndex verbosity) repos)
deps' <- IndexUtils.disambiguateDependencies available deps
......@@ -121,8 +131,25 @@ installRepoPackages verbosity packageDB repos comp conf configFlags deps =
| DepGraph.empty pkgs -> notice verbosity
"All requested packages already installed. Nothing to do."
>> return []
| dryRun -> do
printDryRun pkgs
return []
| otherwise -> installPackages verbosity configFlags pkgs
printDryRun :: DepGraph.DepGraph -> IO ()
printDryRun pkgs
| DepGraph.empty pkgs = putStrLn "No packages to be installed."
| otherwise = do
putStrLn "In order, the following would be installed:"
mapM_ (putStrLn . showPackageId) (order pkgs)
where
order ps
| DepGraph.empty ps = []
| otherwise =
let (DepGraph.ResolvedPackage pkgInfo _ _) = DepGraph.ready ps
pkgId = packageId pkgInfo
in (pkgId : order (DepGraph.removeCompleted pkgId ps))
installPackages :: Verbosity
-> Cabal.ConfigFlags -- ^Options which will be passed to every package.
-> DepGraph.DepGraph
......
......@@ -13,7 +13,7 @@
module Hackage.Setup
( globalCommand, Cabal.GlobalFlags(..)
, configureCommand
, installCommand --Cabal.InstallFlags(..)
, installCommand, InstallFlags(..)
, listCommand
, updateCommand
, upgradeCommand
......@@ -62,16 +62,11 @@ globalCommand = Cabal.globalCommand {
++ "\nSee http://www.haskell.org/cabal/ for more information.\n"
}
configureCommand :: CommandUI Cabal.ConfigFlags
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
commandDefaultFlags = mempty
}
cabalConfigureCommand :: CommandUI Cabal.ConfigFlags
cabalConfigureCommand = Cabal.configureCommand defaultProgramConfiguration
installCommand :: CommandUI Cabal.ConfigFlags
installCommand = (Cabal.configureCommand defaultProgramConfiguration) {
commandName = "install",
commandSynopsis = "Installs a list of packages.",
commandUsage = usagePackages "install",
configureCommand :: CommandUI Cabal.ConfigFlags
configureCommand = cabalConfigureCommand {
commandDefaultFlags = mempty
}
......@@ -145,6 +140,47 @@ checkCommand = CommandUI {
commandOptions = mempty
}
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------
-- Install takes exactly the same flags as configure, but with the addition
-- of doing --dry-run.
data InstallFlags = InstallFlags {
installDryRun :: Flag Bool
}
defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
installDryRun = mempty
}
installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)
installCommand = cabalConfigureCommand {
commandName = "install",
commandSynopsis = "Installs a list of packages.",
commandUsage = usagePackages "install",
commandDefaultFlags = mempty,
commandOptions = \showOrParseArgs ->
liftOptionsFst (commandOptions cabalConfigureCommand showOrParseArgs)
++ liftOptionsSnd [
option [] ["dry-run"]
"Do not install anything, only print what would be installed."
installDryRun (\v flags -> flags { installDryRun = v })
(noArg (toFlag True) (fromFlagOrDefault False))
]
}
instance Monoid InstallFlags where
mempty = defaultInstallFlags
mappend a b = InstallFlags {
installDryRun = combine installDryRun
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------
......@@ -214,6 +250,12 @@ instance Monoid UploadFlags where
-- * GetOpt Utils
-- ------------------------------------------------------------
liftOptionsFst :: [Option a] -> [Option (a,b)]
liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))
liftOptionsSnd :: [Option b] -> [Option (a,b)]
liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))
optionVerbose :: (flags -> Flag Verbosity)
-> (Flag Verbosity -> flags -> flags)
-> Option flags
......
......@@ -28,7 +28,7 @@ import Distribution.Version (VersionRange(..), Dependency(..))
import Distribution.Verbosity (Verbosity)
import qualified Distribution.Simple.Setup as Cabal
import Data.Monoid (Monoid(mconcat))
import Data.Monoid (Monoid(..))
upgrade :: Verbosity
-> PackageDB -> [Repo]
......@@ -43,7 +43,7 @@ upgrade verbosity packageDB repos comp conf configFlags = do
putStrLn "Upgrading the following packages: "
--FIXME: check if upgradable is null
mapM_ putStrLn [showPackageId (packageId x) | x <- upgradable]
install verbosity packageDB repos comp conf configFlags
install verbosity packageDB repos comp conf configFlags mempty
[UnresolvedDependency (identifierToDependency $ packageId x) []
| x <- upgradable]
......
......@@ -119,18 +119,18 @@ configureAction flags extraArgs = do
: commandShowOptions configureCommand flags' ++ extraArgs
setupWrapper args Nothing
installAction :: Cabal.ConfigFlags -> [String] -> IO ()
installAction flags extraArgs = do
installAction :: (Cabal.ConfigFlags, InstallFlags) -> [String] -> IO ()
installAction (cflags,iflags) extraArgs = do
pkgs <- either die return (parsePackageArgs extraArgs)
configFile <- defaultConfigFile --FIXME
let verbosity = fromFlagOrDefault normal (Cabal.configVerbose flags)
let verbosity = fromFlagOrDefault normal (Cabal.configVerbose cflags)
config <- loadConfig verbosity configFile
let flags' = savedConfigToConfigFlags (Cabal.configPackageDB flags) config
`mappend` flags
(comp, conf) <- configCompilerAux flags'
let cflags' = savedConfigToConfigFlags (Cabal.configPackageDB cflags) config
`mappend` cflags
(comp, conf) <- configCompilerAux cflags'
install verbosity
(fromFlag $ Cabal.configPackageDB flags') (configRepos config)
comp conf flags' pkgs
(fromFlag $ Cabal.configPackageDB cflags') (configRepos config)
comp conf cflags' iflags pkgs
infoAction :: Cabal.Flag Verbosity -> [String] -> IO ()
infoAction verbosityFlag extraArgs = do
......
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