Commit c9e046e6 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by GitHub
Browse files

Merge pull request #3815 from dcoutts/only-dependencies

Implement cabal new-build --only-dependencies
parents f0b9ea77 6f1c3701
......@@ -76,7 +76,17 @@ buildAction (configFlags, configExFlags, installFlags, haddockFlags)
, installFlags, haddockFlags )
PreBuildHooks {
hookPrePlanning = \_ _ _ -> return (),
hookSelectPlanSubset = selectBuildTargets userTargets
hookSelectPlanSubset = \buildSettings elaboratedPlan -> do
-- Interpret the targets on the command line as build targets
-- (as opposed to say repl or haddock targets).
selectTargets
verbosity
BuildDefaultComponents
BuildSpecificComponent
userTargets
(buildSettingOnlyDeps buildSettings)
elaboratedPlan
}
printPlan verbosity buildCtx
......@@ -87,11 +97,3 @@ buildAction (configFlags, configExFlags, installFlags, haddockFlags)
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
-- When we interpret the targets on the command line, interpret them as
-- repl targets (as opposed to say repl or haddock targets).
selectBuildTargets =
selectTargets
verbosity
BuildDefaultComponents
BuildSpecificComponent
......@@ -63,7 +63,7 @@ configureAction (configFlags, configExFlags, installFlags, haddockFlags)
-- planning phase.
writeProjectLocalExtraConfig projectRootDir cliConfig,
hookSelectPlanSubset = return
hookSelectPlanSubset = \_ -> return
}
--TODO: Hmm, but we don't have any targets. Currently this prints what we
......
......@@ -25,12 +25,12 @@ import Distribution.Simple.Setup
import Distribution.Verbosity
( normal )
import Control.Monad (unless)
import Control.Monad (when, unless)
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
import Distribution.Simple.Utils
( wrapText )
( wrapText, die )
import qualified Distribution.Client.Setup as Client
replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
......@@ -73,7 +73,25 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags)
, installFlags, haddockFlags )
PreBuildHooks {
hookPrePlanning = \_ _ _ -> return (),
hookSelectPlanSubset = selectReplTargets userTargets
hookSelectPlanSubset = \buildSettings elaboratedPlan -> do
when (buildSettingOnlyDeps buildSettings) $
die $ "The repl command does not support '--only-dependencies'. "
++ "You may wish to use 'build --only-dependencies' and then "
++ "use 'repl'."
-- Interpret the targets on the command line as repl targets
-- (as opposed to say build or haddock targets).
selectTargets
verbosity
ReplDefaultComponent
ReplSpecificComponent
userTargets
False -- onlyDependencies, always False for repl
elaboratedPlan
--TODO: [required eventually] reject multiple targets, or at least
-- targets spanning multiple components. ie it's ok to have two
-- module/file targets in the same component, but not two that live
-- in different components.
}
printPlan verbosity buildCtx
......@@ -84,11 +102,3 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags)
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
-- When we interpret the targets on the command line, interpret them as
-- repl targets (as opposed to say build or haddock targets).
selectReplTargets =
selectTargets
verbosity
ReplDefaultComponent
ReplSpecificComponent
......@@ -311,7 +311,7 @@ lookup :: (IsUnit ipkg, IsUnit srcpkg)
-> Maybe (GenericPlanPackage ipkg srcpkg)
lookup plan pkgid = Graph.lookup pkgid (planIndex plan)
-- | Find all the direct depencencies of the given package.
-- | Find all the direct dependencies of the given package.
--
-- Note that the package must exist in the plan or it is an error.
--
......@@ -323,7 +323,7 @@ directDeps plan pkgid =
Just deps -> deps
Nothing -> internalError "directDeps: package not in graph"
-- | Find all the direct reverse depencencies of the given package.
-- | Find all the direct reverse dependencies of the given package.
--
-- Note that the package must exist in the plan or it is an error.
--
......@@ -342,7 +342,7 @@ revDirectDeps plan pkgid =
-- | Return all the packages in the 'InstallPlan' in reverse topological order.
-- That is, for each package, all depencencies of the package appear first.
-- That is, for each package, all dependencies of the package appear first.
--
-- Compared to 'executionOrder', this function returns all the installed and
-- source packages rather than just the source ones. Also, while both this
......
......@@ -194,7 +194,7 @@ data BuildStatusRebuild =
| BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason
data BuildReason =
-- | The depencencies of this package have been (re)built so the build
-- | The dependencies of this package have been (re)built so the build
-- phase needs to be rerun.
--
-- The optional registration info here tells us if we've registered the
......@@ -325,10 +325,10 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install
-- | A specialised traversal over the packages in an install plan.
--
-- The packages are visited in dependency order, starting with packages with no
-- depencencies. The result for each package is accumulated into a 'Map' and
-- dependencies. The result for each package is accumulated into a 'Map' and
-- returned as the final result. In addition, when visting a package, the
-- visiting function is passed the results for all the immediate package
-- depencencies. This can be used to propagate information from depencencies.
-- dependencies. This can be used to propagate information from dependencies.
--
foldMInstallPlanDepOrder
:: forall m ipkg srcpkg b.
......@@ -480,7 +480,7 @@ checkPackageFileMonitorChanged PackageFileMonitor{..}
MonitorUnchanged () _
-- The configChanged here includes the identity of the dependencies,
-- so depsBuildStatus is just needed for the changes in the content
-- of depencencies.
-- of dependencies.
| any buildStatusRequiresBuild depsBuildStatus -> do
regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()
let mreg = changedToMaybe regChanged
......
......@@ -90,7 +90,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS
import Data.List
import Data.Maybe
import Data.Either
import Control.Exception (Exception(..))
import Control.Exception (Exception(..), throwIO)
import System.Exit (ExitCode(..), exitFailure)
#ifdef MIN_VERSION_unix
import System.Posix.Signals (sigKILL, sigSEGV)
......@@ -114,7 +114,8 @@ data PreBuildHooks = PreBuildHooks {
-> DistDirLayout
-> ProjectConfig
-> IO (),
hookSelectPlanSubset :: ElaboratedInstallPlan
hookSelectPlanSubset :: BuildTimeSettings
-> ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
}
......@@ -177,7 +178,7 @@ runProjectPreBuildPhase
-- Now given the specific targets the user has asked for, decide
-- which bits of the plan we will want to execute.
--
elaboratedPlan' <- hookSelectPlanSubset elaboratedPlan
elaboratedPlan' <- hookSelectPlanSubset buildSettings elaboratedPlan
-- Check if any packages don't need rebuilding, and improve the plan.
-- This also gives us more accurate reasons for the --dry-run output.
......@@ -268,10 +269,11 @@ runProjectBuildPhase verbosity ProjectBuildContext {..} =
selectTargets :: Verbosity -> PackageTarget
-> (ComponentTarget -> PackageTarget)
-> [UserBuildTarget]
-> Bool
-> ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
selectTargets verbosity targetDefaultComponents targetSpecificComponent
userBuildTargets installPlan = do
userBuildTargets onlyDependencies installPlan = do
-- Match the user targets against the available targets. If no targets are
-- given this uses the package in the current directory, if any.
......@@ -300,9 +302,15 @@ selectTargets verbosity targetDefaultComponents targetSpecificComponent
debug verbosity ("buildTargets': " ++ show buildTargets')
-- Finally, prune the install plan to cover just those target packages
-- and their deps.
-- and their deps (or only their deps with the --only-dependencies flag).
--
return (pruneInstallPlanToTargets buildTargets' installPlan)
let installPlan' = pruneInstallPlanToTargets
buildTargets' installPlan
if onlyDependencies
then either throwIO return $
pruneInstallPlanToDependencies
(Map.keysSet buildTargets') installPlan'
else return installPlan'
where
localPackages =
[ (elabPkgDescription elab, elabPkgSourceLocation elab)
......
......@@ -2,6 +2,7 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | Planning how to build everything in a project.
--
......@@ -26,6 +27,7 @@ module Distribution.Client.ProjectPlanning (
-- * Selecting a plan subset
pruneInstallPlanToTargets,
pruneInstallPlanToDependencies,
-- * Utils required for building
pkgHasEphemeralBuildTargets,
......@@ -77,7 +79,6 @@ import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb
import Distribution.Solver.Types.ResolverPackage
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.InstSolverPackage
......@@ -125,6 +126,7 @@ import Control.Applicative
import Control.Monad
import Control.Monad.State as State
import Control.Exception
import Data.Typeable
import Data.List
import Data.Maybe
import Data.Either
......@@ -1723,13 +1725,14 @@ elabBuildTargetWholeComponents elab =
--
pruneInstallPlanToTargets :: Map UnitId [PackageTarget]
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets perPkgTargetsMap =
InstallPlan.new (IndependentGoals False)
pruneInstallPlanToTargets perPkgTargetsMap elaboratedPlan =
InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)
. Graph.fromList
-- We have to do this in two passes
. pruneInstallPlanPass2
. pruneInstallPlanPass1 perPkgTargetsMap
. InstallPlan.toList
$ elaboratedPlan
-- | This is a temporary data type, where we temporarily
-- override the graph dependencies of an 'ElaboratedPackage',
......@@ -1999,6 +2002,86 @@ componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas
componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas
componentOptionalStanza _ = Nothing
------------------------------------
-- Support for --only-dependencies
--
-- | Try to remove the given targets from the install plan.
--
-- This is not always possible.
--
pruneInstallPlanToDependencies :: Set UnitId
-> ElaboratedInstallPlan
-> Either CannotPruneDependencies
ElaboratedInstallPlan
pruneInstallPlanToDependencies pkgTargets installPlan =
assert (all (isJust . InstallPlan.lookup installPlan)
(Set.toList pkgTargets)) $
fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))
. checkBrokenDeps
. Graph.fromList
. filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)
. InstallPlan.toList
$ installPlan
where
-- Our strategy is to remove the packages we don't want and then check
-- if the remaining graph is broken or not, ie any packages with dangling
-- dependencies. If there are then we cannot prune the given targets.
checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage
-> Either CannotPruneDependencies
(Graph.Graph ElaboratedPlanPackage)
checkBrokenDeps graph =
case Graph.broken graph of
[] -> Right graph
brokenPackages ->
Left $ CannotPruneDependencies
[ (pkg, missingDeps)
| (pkg, missingDepIds) <- brokenPackages
, let missingDeps = catMaybes (map lookupDep missingDepIds)
]
where
-- lookup in the original unpruned graph
lookupDep = InstallPlan.lookup installPlan
-- | It is not always possible to prune to only the dependencies of a set of
-- targets. It may be the case that removing a package leaves something else
-- that still needed the pruned package.
--
-- This lists all the packages that would be broken, and their dependencies
-- that would be missing if we did prune.
--
newtype CannotPruneDependencies =
CannotPruneDependencies [(ElaboratedPlanPackage,
[ElaboratedPlanPackage])]
#if MIN_VERSION_base(4,8,0)
deriving (Show, Typeable)
#else
deriving (Typeable)
instance Show CannotPruneDependencies where
show = renderCannotPruneDependencies
#endif
instance Exception CannotPruneDependencies where
#if MIN_VERSION_base(4,8,0)
displayException = renderCannotPruneDependencies
#endif
renderCannotPruneDependencies :: CannotPruneDependencies -> String
renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) =
"Cannot select only the dependencies (as requested by the "
++ "'--only-dependencies' flag), "
++ (case pkgids of
[pkgid] -> "the package " ++ display pkgid ++ " is "
_ -> "the packages "
++ intercalate ", " (map display pkgids) ++ " are ")
++ "required by a dependency of one of the other targets."
where
-- throw away the details and just list the deps that are needed
pkgids :: [PackageId]
pkgids = nub . map packageId . concatMap snd $ brokenPackages
---------------------------
-- Setup.hs script policy
......
......@@ -341,7 +341,7 @@ preferBaseGoalChoice = trav go
isBase _ = False
-- | Deal with setup dependencies after regular dependencies, so that we can
-- will link setup depencencies against package dependencies when possible
-- will link setup dependencies against package dependencies when possible
deferSetupChoices :: Tree a -> Tree a
deferSetupChoices = trav go
where
......
......@@ -497,6 +497,8 @@ Test-Suite unit-tests
else
build-depends: unix
ghc-options: -fno-ignore-asserts
if !(arch(arm) && impl(ghc < 7.6))
ghc-options: -threaded
......@@ -515,7 +517,7 @@ Test-Suite solver-quickcheck
type: exitcode-stdio-1.0
main-is: SolverQuickCheck.hs
hs-source-dirs: tests, .
ghc-options: -Wall -fwarn-tabs
ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts
other-modules:
UnitTests.Distribution.Solver.Modular.DSL
UnitTests.Distribution.Solver.Modular.QuickCheck
......@@ -600,7 +602,7 @@ test-suite integration-tests
if !(arch(arm) && impl(ghc < 7.6))
ghc-options: -threaded
ghc-options: -Wall
ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts
default-language: Haskell2010
-- Integration tests that use the cabal-install code directly
......
......@@ -2,3 +2,7 @@ packages: Cabal/ cabal-install/
-- Uncomment to allow picking up extra local unpacked deps:
--optional-packages: */
program-options
-- So us hackers get all the assertion failures early:
ghc-options: -fno-ignore-asserts
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