From d9bf6788adf6d416d6335fd79c4c1b3fbc7d0ad1 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Sun, 31 Jul 2016 21:17:58 -0700
Subject: [PATCH] Per-component new-build support (no Custom support yet).
A bit of a megapatch. Here's what's in it:
* First, a few miscellaneous utility functions and reexports
in Cabal. I could have split these into a separate commit
but I was too lazy to.
* Distribution.Client.Install got refactored:
instead of using PackageFixedDeps, it uses IsUnit
instead. This is because we weren't using ComponentDeps
in a nontrivial way; we just need some graph structure
and IsNode (with UnitId keys) fulfills that. I also removed the
invariant checking and error reporting because it was
being annoying (we check the invariants already in
SolverInstallPlan).
* Look at Distribution.Client.ProjectPlanning.Types.
This contains the primary type change: ElaboratedConfiguredPackage
is now EITHER a monolithic ElaboratedPackage, or a per-component
ElaboratedComponent (it should get renamed but I didn't do that
in this patch.) These are what we're going to store in our
plans: if a package we're building has a Setup script which supports
per-component builds, we'll explode it into a component. Otherwise
we'll keep it as a package. We'll see codepaths for both
throughout.
* OK, so the expansion happens in ProjectPlanning, mostly in
'elaborateAndExpandSolverPackage'. You should review the
package hash computation code closely. When we can separate
components, we compute a hash for each INDEPENDENTLY. This
is good: we get more sharing.
* We need to adjust the target resolution and pruning code
in ProjectOrchestration and ProjectPlanning. I did a dumb
but easy idea: if a user mentions 'packagename' in a
target name, I spray the PackageTarget on every
possibly relevant IPID in buildTargets', and then pare
it down later.
* And of course there's code in ProjectBuilding to actual
do a configure and then build.
* We change the layout of build directories so that we can
track each component separately. While I was doing that,
I also added compiler and platform information.
Custom doesn't work yet because I need to give them their own
separate component, and teach Cabal how to build them specially.
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
---
Cabal/Distribution/Package.hs | 5 +
Cabal/Distribution/Simple/Configure.hs | 2 +
.../Types/ComponentEnabledSpec.hs | 2 +-
.../Distribution/Types/PackageDescription.hs | 9 +
cabal-install/Distribution/Client/CmdBuild.hs | 1 +
.../Distribution/Client/CmdFreeze.hs | 10 +-
cabal-install/Distribution/Client/CmdRepl.hs | 1 +
.../Distribution/Client/DistDirLayout.hs | 54 +-
cabal-install/Distribution/Client/Install.hs | 5 +-
.../Distribution/Client/InstallPlan.hs | 275 ++++-------
.../Distribution/Client/PackageHash.hs | 5 +
.../Distribution/Client/ProjectBuilding.hs | 216 ++++----
.../Client/ProjectOrchestration.hs | 75 ++-
.../Distribution/Client/ProjectPlanOutput.hs | 35 +-
.../Distribution/Client/ProjectPlanning.hs | 461 +++++++++++++-----
.../Client/ProjectPlanning/Types.hs | 184 ++++++-
cabal-install/Distribution/Client/Types.hs | 44 +-
.../Solver/Types/ComponentDeps.hs | 10 +
cabal-install/cabal-install.cabal | 5 +
.../internal-libs/new_build.sh | 3 +-
.../new-build/executable/Main.hs | 1 +
.../new-build/executable/Setup.hs | 2 +
.../new-build/executable/Test.hs | 1 +
.../new-build/executable/a.cabal | 15 +
.../new-build/executable/cabal.project | 1 +
cabal-install/tests/IntegrationTests2.hs | 17 +-
.../exception/configure/a.cabal | 6 +
.../Distribution/Client/InstallPlan.hs | 23 +-
28 files changed, 996 insertions(+), 472 deletions(-)
create mode 100644 cabal-install/tests/IntegrationTests/new-build/executable/Main.hs
create mode 100644 cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs
create mode 100644 cabal-install/tests/IntegrationTests/new-build/executable/Test.hs
create mode 100644 cabal-install/tests/IntegrationTests/new-build/executable/a.cabal
create mode 100644 cabal-install/tests/IntegrationTests/new-build/executable/cabal.project
diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs
index 0431b3d280..5e7ff259ae 100644
--- a/Cabal/Distribution/Package.hs
+++ b/Cabal/Distribution/Package.hs
@@ -27,6 +27,7 @@ module Distribution.Package (
UnitId(..),
mkUnitId,
mkLegacyUnitId,
+ unitIdComponentId,
getHSLibraryName,
InstalledPackageId, -- backwards compat
@@ -176,6 +177,10 @@ mkUnitId = SimpleUnitId . ComponentId
mkLegacyUnitId :: PackageId -> UnitId
mkLegacyUnitId = SimpleUnitId . ComponentId . display
+-- | Extract 'ComponentId' from 'UnitId'.
+unitIdComponentId :: UnitId -> ComponentId
+unitIdComponentId (SimpleUnitId cid) = cid
+
-- ------------------------------------------------------------
-- * Package source dependencies
-- ------------------------------------------------------------
diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs
index 55ab9e9f52..b9ce2f366b 100644
--- a/Cabal/Distribution/Simple/Configure.hs
+++ b/Cabal/Distribution/Simple/Configure.hs
@@ -35,6 +35,8 @@ module Distribution.Simple.Configure (configure,
tryGetPersistBuildConfig,
maybeGetPersistBuildConfig,
findDistPref, findDistPrefOrDefault,
+ mkComponentsGraph,
+ getInternalPackages,
computeComponentId,
computeCompatPackageKey,
computeCompatPackageName,
diff --git a/Cabal/Distribution/Types/ComponentEnabledSpec.hs b/Cabal/Distribution/Types/ComponentEnabledSpec.hs
index b78259cddf..2ecfb1f15c 100644
--- a/Cabal/Distribution/Types/ComponentEnabledSpec.hs
+++ b/Cabal/Distribution/Types/ComponentEnabledSpec.hs
@@ -54,7 +54,7 @@ data ComponentEnabledSpec
= ComponentEnabledSpec { testsEnabled :: Bool,
benchmarksEnabled :: Bool }
| OneComponentEnabledSpec ComponentName
- deriving (Generic, Read, Show)
+ deriving (Generic, Read, Show, Eq)
instance Binary ComponentEnabledSpec
-- | The default set of enabled components. Historically tests and
diff --git a/Cabal/Distribution/Types/PackageDescription.hs b/Cabal/Distribution/Types/PackageDescription.hs
index b026d571fd..734ca3506f 100644
--- a/Cabal/Distribution/Types/PackageDescription.hs
+++ b/Cabal/Distribution/Types/PackageDescription.hs
@@ -43,6 +43,7 @@ module Distribution.Types.PackageDescription (
updatePackageDescription,
pkgComponents,
pkgBuildableComponents,
+ enabledComponents,
lookupComponent,
getComponent,
) where
@@ -57,6 +58,7 @@ import Distribution.Types.Benchmark
import Distribution.Types.Component
import Distribution.Types.ComponentName
+import Distribution.Types.ComponentEnabledSpec
import Distribution.Types.SetupBuildInfo
import Distribution.Types.BuildInfo
import Distribution.Types.BuildType
@@ -346,6 +348,13 @@ pkgComponents pkg =
pkgBuildableComponents :: PackageDescription -> [Component]
pkgBuildableComponents = filter componentBuildable . pkgComponents
+-- | A list of all components in the package that are enabled.
+--
+-- @since 2.0.0.0
+--
+enabledComponents :: PackageDescription -> ComponentEnabledSpec -> [Component]
+enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg
+
lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
lookupComponent pkg CLibName = fmap CLib (library pkg)
lookupComponent pkg (CSubLibName name) =
diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs
index 8a5afe80c8..840ecf9a74 100644
--- a/cabal-install/Distribution/Client/CmdBuild.hs
+++ b/cabal-install/Distribution/Client/CmdBuild.hs
@@ -63,6 +63,7 @@ buildAction (configFlags, configExFlags, installFlags, haddockFlags)
-- repl targets (as opposed to say repl or haddock targets).
selectBuildTargets =
selectTargets
+ verbosity
BuildDefaultComponents
BuildSpecificComponent
diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs
index 1aa072ecd9..95b41c5a98 100644
--- a/cabal-install/Distribution/Client/CmdFreeze.hs
+++ b/cabal-install/Distribution/Client/CmdFreeze.hs
@@ -7,13 +7,11 @@ module Distribution.Client.CmdFreeze (
) where
import Distribution.Client.ProjectPlanning
- ( ElaboratedInstallPlan, rebuildInstallPlan )
import Distribution.Client.ProjectConfig
( ProjectConfig(..), ProjectConfigShared(..)
, commandLineFlagsToProjectConfig, writeProjectLocalFreezeConfig
, findProjectRoot )
import Distribution.Client.ProjectPlanning.Types
- ( ElaboratedConfiguredPackage(..) )
import Distribution.Client.Targets
( UserConstraint(..) )
import Distribution.Solver.Types.ConstraintSource
@@ -149,8 +147,9 @@ projectFreezeConstraints plan =
flagAssignments =
Map.fromList
[ (pkgname, flags)
- | InstallPlan.Configured pkg <- InstallPlan.toList plan
- , let flags = pkgFlagAssignment pkg
+ | InstallPlan.Configured pkg_or_comp <- InstallPlan.toList plan
+ , let pkg = getElaboratedPackage pkg_or_comp
+ flags = pkgFlagAssignment pkg
pkgname = packageName pkg
, not (null flags) ]
@@ -158,7 +157,8 @@ projectFreezeConstraints plan =
localPackages =
Map.fromList
[ (packageName pkg, ())
- | InstallPlan.Configured pkg <- InstallPlan.toList plan
+ | InstallPlan.Configured pkg_or_comp <- InstallPlan.toList plan
+ , let pkg = getElaboratedPackage pkg_or_comp
, pkgLocalToProject pkg
]
diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs
index e277f50147..3bce9cee58 100644
--- a/cabal-install/Distribution/Client/CmdRepl.hs
+++ b/cabal-install/Distribution/Client/CmdRepl.hs
@@ -67,6 +67,7 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags)
-- repl targets (as opposed to say build or haddock targets).
selectReplTargets =
selectTargets
+ verbosity
ReplDefaultComponent
ReplSpecificComponent
diff --git a/cabal-install/Distribution/Client/DistDirLayout.hs b/cabal-install/Distribution/Client/DistDirLayout.hs
index 41e8dd25bd..cdf6f37ec1 100644
--- a/cabal-install/Distribution/Client/DistDirLayout.hs
+++ b/cabal-install/Distribution/Client/DistDirLayout.hs
@@ -5,17 +5,43 @@
-- The layout of the .\/dist\/ directory where cabal keeps all of it's state
-- and build artifacts.
--
-module Distribution.Client.DistDirLayout where
+module Distribution.Client.DistDirLayout (
+ -- 'DistDirLayout'
+ DistDirLayout(..),
+ DistDirParams(..),
+ defaultDistDirLayout,
+
+ -- * 'CabalDirLayout'
+ CabalDirLayout(..),
+ defaultCabalDirLayout,
+) where
import System.FilePath
import Distribution.Package
- ( PackageId )
+ ( PackageId, UnitId(..) )
import Distribution.Compiler
import Distribution.Simple.Compiler (PackageDB(..))
import Distribution.Text
+import Distribution.Types.ComponentName
+import Distribution.System
import Distribution.Client.Types
( InstalledPackageId )
+-- | Information which can be used to construct the path to
+-- the build directory of a build. This is LESS fine-grained
+-- than what goes into the hashed 'InstalledPackageId',
+-- and for good reason: we don't want this path to change if
+-- the user, say, adds a dependency to their project.
+data DistDirParams = DistDirParams {
+ distParamUnitId :: UnitId,
+ distParamPackageId :: PackageId,
+ distParamComponentName :: Maybe ComponentName,
+ distParamCompilerId :: CompilerId,
+ distParamPlatform :: Platform
+ -- TODO (see #3343):
+ -- Flag assignments
+ -- Optimization
+ }
-- | The layout of the project state directory. Traditionally this has been
@@ -31,11 +57,11 @@ data DistDirLayout = DistDirLayout {
-- | The directory under dist where we keep the build artifacts for a
-- package we're building from a local directory.
--
- -- This uses a 'PackageId' not just a 'PackageName' because technically
+ -- This uses a 'UnitId' not just a 'PackageName' because technically
-- we can have multiple instances of the same package in a solution
-- (e.g. setup deps).
--
- distBuildDirectory :: PackageId -> FilePath,
+ distBuildDirectory :: DistDirParams -> FilePath,
distBuildRootDirectory :: FilePath,
-- | The directory under dist where we put the unpacked sources of
@@ -55,8 +81,8 @@ data DistDirLayout = DistDirLayout {
-- | The location for package-specific cache files (e.g. state used in
-- incremental rebuilds).
--
- distPackageCacheFile :: PackageId -> String -> FilePath,
- distPackageCacheDirectory :: PackageId -> FilePath,
+ distPackageCacheFile :: DistDirParams -> String -> FilePath,
+ distPackageCacheDirectory :: DistDirParams -> FilePath,
distTempDirectory :: FilePath,
distBinDirectory :: FilePath,
@@ -88,7 +114,17 @@ defaultDistDirLayout projectRootDirectory =
--TODO: switch to just dist at some point, or some other new name
distBuildRootDirectory = distDirectory </> "build"
- distBuildDirectory pkgid = distBuildRootDirectory </> display pkgid
+ distBuildDirectory params =
+ distBuildRootDirectory </>
+ display (distParamPlatform params) </>
+ display (distParamCompilerId params) </>
+ display (distParamPackageId params) </>
+ (case fmap componentNameString (distParamComponentName params) of
+ Nothing -> ""
+ Just Nothing -> ""
+ Just (Just str) -> "c" </> str) </>
+ (case distParamUnitId params of -- For Backpack
+ SimpleUnitId _ -> "")
distUnpackedSrcRootDirectory = distDirectory </> "src"
distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory
@@ -97,8 +133,8 @@ defaultDistDirLayout projectRootDirectory =
distProjectCacheDirectory = distDirectory </> "cache"
distProjectCacheFile name = distProjectCacheDirectory </> name
- distPackageCacheDirectory pkgid = distBuildDirectory pkgid </> "cache"
- distPackageCacheFile pkgid name = distPackageCacheDirectory pkgid </> name
+ distPackageCacheDirectory params = distBuildDirectory params </> "cache"
+ distPackageCacheFile params name = distPackageCacheDirectory params </> name
distTempDirectory = distDirectory </> "tmp"
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 4a3b43eacc..44e717a4a3 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -116,7 +116,6 @@ import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex
-import Distribution.Solver.Types.PackageFixedDeps
import Distribution.Solver.Types.PkgConfigDb
( PkgConfigDb, readPkgConfigDb )
import Distribution.Solver.Types.SourcePackage as SourcePackage
@@ -614,12 +613,12 @@ packageStatus installedPkgIndex cpkg =
changes :: Installed.InstalledPackageInfo
-> ReadyPackage
-> [MergeResult PackageIdentifier PackageIdentifier]
- changes pkg pkg' = filter changed $
+ changes pkg (ReadyPackage pkg') = filter changed $
mergeBy (comparing packageName)
-- deps of installed pkg
(resolveInstalledIds $ Installed.depends pkg)
-- deps of configured pkg
- (resolveInstalledIds $ CD.nonSetupDeps (depends pkg'))
+ (resolveInstalledIds $ map confInstId (CD.nonSetupDeps (confPkgDeps pkg')))
-- convert to source pkg ids via index
resolveInstalledIds :: [UnitId] -> [PackageIdentifier]
diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs
index 429b53ccd2..25eed68a6e 100644
--- a/cabal-install/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/Distribution/Client/InstallPlan.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
@@ -21,10 +22,12 @@ module Distribution.Client.InstallPlan (
GenericInstallPlan,
PlanPackage,
GenericPlanPackage(..),
+ IsUnit,
-- * Operations on 'InstallPlan's
new,
toList,
+ planIndepGoals,
fromSolverInstallPlan,
configureInstallPlan,
@@ -42,7 +45,6 @@ module Distribution.Client.InstallPlan (
-- ** Traversal helpers
-- $traversal
Processing,
- -- NB: these functions are only used by the legacy install-path
ready,
completed,
failed,
@@ -64,17 +66,16 @@ import qualified Distribution.Simple.Setup as Cabal
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.Package
- ( PackageIdentifier(..), Package(..)
+ ( Package(..)
, HasUnitId(..), UnitId(..) )
import Distribution.Solver.Types.SolverPackage
import Distribution.Client.JobControl
import Distribution.Text
- ( display )
+import Text.PrettyPrint
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.PackageFixedDeps
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
@@ -82,9 +83,9 @@ import Distribution.Solver.Types.SolverId
-- import qualified Distribution.Simple.Configure as Configure
import Data.List
- ( foldl', intercalate )
+ ( foldl' )
import Data.Maybe
- ( fromMaybe, catMaybes, isJust )
+ ( fromMaybe, isJust )
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, IsNode(..))
import Distribution.Compat.Binary (Binary(..))
@@ -152,18 +153,23 @@ import Prelude hiding (lookup)
-- dependencies in cabal-install should consider what to do with these
-- dependencies; if we give a 'PackageInstalled' instance it would be too easy
-- to get this wrong (and, for instance, call graph traversal functions from
--- Cabal rather than from cabal-install). Instead, see 'PackageFixedDeps'.
+-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.
data GenericPlanPackage ipkg srcpkg
= PreExisting ipkg
| Configured srcpkg
deriving (Eq, Show, Generic)
-instance (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+type IsUnit a = (IsNode a, Key a ~ UnitId)
+
+-- NB: Expanded constraint synonym here to avoid undecidable
+-- instance errors in GHC 7.8 and earlier.
+instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
=> IsNode (GenericPlanPackage ipkg srcpkg) where
- type Key (GenericPlanPackage ipkg srcpkg) = UnitId -- TODO: change me
- nodeKey = installedUnitId
- nodeNeighbors = CD.flatDeps . depends
+ type Key (GenericPlanPackage ipkg srcpkg) = UnitId
+ nodeKey (PreExisting ipkg) = nodeKey ipkg
+ nodeKey (Configured spkg) = nodeKey spkg
+ nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg
+ nodeNeighbors (Configured spkg) = nodeNeighbors spkg
instance (Binary ipkg, Binary srcpkg)
=> Binary (GenericPlanPackage ipkg srcpkg)
@@ -176,18 +182,17 @@ instance (Package ipkg, Package srcpkg) =>
packageId (PreExisting ipkg) = packageId ipkg
packageId (Configured spkg) = packageId spkg
-instance (PackageFixedDeps srcpkg,
- PackageFixedDeps ipkg) =>
- PackageFixedDeps (GenericPlanPackage ipkg srcpkg) where
- depends (PreExisting pkg) = depends pkg
- depends (Configured pkg) = depends pkg
-
instance (HasUnitId ipkg, HasUnitId srcpkg) =>
HasUnitId
(GenericPlanPackage ipkg srcpkg) where
installedUnitId (PreExisting ipkg) = installedUnitId ipkg
installedUnitId (Configured spkg) = installedUnitId spkg
+instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
+ HasConfiguredId (GenericPlanPackage ipkg srcpkg) where
+ configuredId (PreExisting ipkg) = configuredId ipkg
+ configuredId (Configured pkg) = configuredId pkg
+
data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
planIndex :: !(PlanIndex ipkg srcpkg),
planIndepGoals :: !IndependentGoals
@@ -200,13 +205,6 @@ type InstallPlan = GenericInstallPlan
type PlanIndex ipkg srcpkg =
Graph (GenericPlanPackage ipkg srcpkg)
-invariant :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
- => GenericInstallPlan ipkg srcpkg -> Bool
-invariant plan =
- valid (planIndepGoals plan)
- (planIndex plan)
-
-- | Smart constructor that deals with caching the 'Graph' representation.
--
mkInstallPlan :: PlanIndex ipkg srcpkg
@@ -221,8 +219,7 @@ mkInstallPlan index indepGoals =
internalError :: String -> a
internalError msg = error $ "InstallPlan: internal error: " ++ msg
-instance (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg,
+instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
Binary ipkg, Binary srcpkg)
=> Binary (GenericInstallPlan ipkg srcpkg) where
put GenericInstallPlan {
@@ -234,16 +231,19 @@ instance (HasUnitId ipkg, PackageFixedDeps ipkg,
(index, indepGoals) <- get
return $! mkInstallPlan index indepGoals
-showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg)
+showPlanIndex :: (Package ipkg, Package srcpkg,
+ IsUnit ipkg, IsUnit srcpkg)
=> PlanIndex ipkg srcpkg -> String
-showPlanIndex index =
- intercalate "\n" (map showPlanPackage (Graph.toList index))
- where showPlanPackage p =
- showPlanPackageTag p ++ " "
- ++ display (packageId p) ++ " ("
- ++ display (installedUnitId p) ++ ")"
-
-showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg)
+showPlanIndex index = renderStyle defaultStyle $
+ vcat (map dispPlanPackage (Graph.toList index))
+ where dispPlanPackage p =
+ hang (hsep [ text (showPlanPackageTag p)
+ , disp (packageId p)
+ , parens (disp (nodeKey p))]) 2
+ (vcat (map disp (nodeNeighbors p)))
+
+showInstallPlan :: (Package ipkg, Package srcpkg,
+ IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg -> String
showInstallPlan = showPlanIndex . planIndex
@@ -253,16 +253,10 @@ showPlanPackageTag (Configured _) = "Configured"
-- | Build an installation plan from a valid set of resolved packages.
--
-new :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
- => IndependentGoals
+new :: IndependentGoals
-> PlanIndex ipkg srcpkg
- -> Either [PlanProblem ipkg srcpkg]
- (GenericInstallPlan ipkg srcpkg)
-new indepGoals index =
- case problems indepGoals index of
- [] -> Right (mkInstallPlan index indepGoals)
- probs -> Left probs
+ -> GenericInstallPlan ipkg srcpkg
+new indepGoals index = mkInstallPlan index indepGoals
toList :: GenericInstallPlan ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
@@ -274,12 +268,10 @@ toList = Graph.toList . planIndex
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
--
-remove :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+remove :: (IsUnit ipkg, IsUnit srcpkg)
=> (GenericPlanPackage ipkg srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg
- -> Either [PlanProblem ipkg srcpkg]
- (GenericInstallPlan ipkg srcpkg)
+ -> GenericInstallPlan ipkg srcpkg
remove shouldRemove plan =
new (planIndepGoals plan) newIndex
where
@@ -290,13 +282,13 @@ remove shouldRemove plan =
-- must have exactly the same dependencies as the source one was configured
-- with.
--
-preexisting :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+preexisting :: (IsUnit ipkg,
+ IsUnit srcpkg)
=> UnitId
-> ipkg
-> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg
-preexisting pkgid ipkg plan = assert (invariant plan') plan'
+preexisting pkgid ipkg plan = plan'
where
plan' = plan {
planIndex = Graph.insert (PreExisting ipkg)
@@ -308,8 +300,7 @@ preexisting pkgid ipkg plan = assert (invariant plan') plan'
-- | Lookup a package in the plan.
--
-lookup :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+lookup :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> UnitId
-> Maybe (GenericPlanPackage ipkg srcpkg)
@@ -340,70 +331,7 @@ revDirectDeps plan pkgid =
Nothing -> internalError "revDirectDeps: package not in graph"
--- ------------------------------------------------------------
--- * Checking validity of plans
--- ------------------------------------------------------------
-
--- | A valid installation plan is a set of packages that is 'acyclic',
--- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the
--- plan has to have a valid configuration (see 'configuredPackageValid').
---
--- * if the result is @False@ use 'problems' to get a detailed list.
---
-valid :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
- => IndependentGoals
- -> PlanIndex ipkg srcpkg
- -> Bool
-valid indepGoals index =
- null $ problems indepGoals index
-
-data PlanProblem ipkg srcpkg =
- PackageMissingDeps (GenericPlanPackage ipkg srcpkg)
- [PackageIdentifier]
- | PackageCycle [GenericPlanPackage ipkg srcpkg]
- | PackageStateInvalid (GenericPlanPackage ipkg srcpkg)
- (GenericPlanPackage ipkg srcpkg)
-
--- | For an invalid plan, produce a detailed list of problems as human readable
--- error messages. This is mainly intended for debugging purposes.
--- Use 'showPlanProblem' for a human readable explanation.
---
-problems :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
- => IndependentGoals
- -> PlanIndex ipkg srcpkg
- -> [PlanProblem ipkg srcpkg]
-problems _indepGoals index =
-
- [ PackageMissingDeps pkg
- (catMaybes
- (map
- (fmap packageId . flip Graph.lookup index)
- missingDeps))
- | (pkg, missingDeps) <- Graph.broken index ]
-
- ++ [ PackageCycle cycleGroup
- | cycleGroup <- Graph.cycles index ]
- ++ [ PackageStateInvalid pkg pkg'
- | pkg <- Graph.toList index
- , Just pkg' <- map (flip Graph.lookup index)
- (CD.flatDeps (depends pkg))
- , not (stateDependencyRelation pkg pkg') ]
-
-
--- | The states of packages have that depend on each other must respect
--- this relation. That is for very case where package @a@ depends on
--- package @b@ we require that @dependencyStatesOk a b = True@.
---
-stateDependencyRelation :: GenericPlanPackage ipkg srcpkg
- -> GenericPlanPackage ipkg srcpkg
- -> Bool
-stateDependencyRelation (PreExisting _) (PreExisting _) = True
-stateDependencyRelation (Configured _) (PreExisting _) = True
-stateDependencyRelation (Configured _) (Configured _) = True
-stateDependencyRelation (PreExisting _) (Configured _) = False
@@ -431,59 +359,66 @@ reverseDependencyClosure plan = fromMaybe []
. Graph.revClosure (planIndex plan)
+-- Alert alert! Why does SolverId map to a LIST of plan packages?
+-- The sordid story has to do with 'build-depends' on a package
+-- with libraries and executables. In an ideal world, we would
+-- ONLY depend on the library in this situation. But c.f. #3661
+-- some people rely on the build-depends to ALSO implicitly
+-- depend on an executable.
+--
+-- I don't want to commit to a strategy yet, so the only possible
+-- thing you can do in this case is return EVERYTHING and let
+-- the client filter out what they want (executables? libraries?
+-- etc). This similarly implies we can't return a 'ConfiguredId'
+-- because that's not enough information.
+
fromSolverInstallPlan ::
- (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
- -- Maybe this should be a UnitId not ConfiguredId?
- => ( (SolverId -> ConfiguredId)
+ (IsUnit ipkg, IsUnit srcpkg)
+ => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan.SolverPlanPackage
- -> GenericPlanPackage ipkg srcpkg)
+ -> [GenericPlanPackage ipkg srcpkg] )
-> SolverInstallPlan
-> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan f plan =
- mkInstallPlan (Graph.fromList pkgs')
+ mkInstallPlan (Graph.fromList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
where
- (_, pkgs') = foldl' f' (Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan)
+ (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
+ (SolverInstallPlan.reverseTopologicalOrder plan)
- f' (pidMap, pkgs) pkg = (pidMap', pkg' : pkgs)
+ f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)
where
- pkg' = f (mapDep pidMap) pkg
-
- pidMap'
- = case sid of
- PreExistingId _pid uid ->
- assert (uid == uid') pidMap
- PlannedId pid ->
- Map.insert pid uid' pidMap
- where
- sid = nodeKey pkg
- uid' = nodeKey pkg'
-
- mapDep _ (PreExistingId pid uid) = ConfiguredId pid uid
- mapDep pidMap (PlannedId pid)
- | Just uid <- Map.lookup pid pidMap
- = ConfiguredId pid uid
- -- This shouldn't happen, since mapDep should only be called
- -- on neighbor SolverId, which must have all been done already
- -- by the reverse top-sort (this also assumes that the graph
- -- is not broken).
- | otherwise
- = error ("fromSolverInstallPlan mapDep: " ++ display pid)
+ pkgs' = f (mapDep pidMap ipiMap) pkg
+
+ (pidMap', ipiMap')
+ = case nodeKey pkg of
+ PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
+ PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
+
+ mapDep _ ipiMap (PreExistingId _pid uid)
+ | Just pkgs <- Map.lookup uid ipiMap = pkgs
+ | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)
+ mapDep pidMap _ (PlannedId pid)
+ | Just pkgs <- Map.lookup pid pidMap = pkgs
+ | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)
+ -- This shouldn't happen, since mapDep should only be called
+ -- on neighbor SolverId, which must have all been done already
+ -- by the reverse top-sort (we assume the graph is not broken).
-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.
-- Similar to 'elaboratedInstallPlan'
configureInstallPlan :: SolverInstallPlan -> InstallPlan
configureInstallPlan solverPlan =
flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->
- case planpkg of
+ [case planpkg of
SolverInstallPlan.PreExisting pkg _ ->
PreExisting pkg
SolverInstallPlan.Configured pkg ->
Configured (configureSolverPackage mapDep pkg)
+ ]
where
- configureSolverPackage :: (SolverId -> ConfiguredId)
+ configureSolverPackage :: (SolverId -> [PlanPackage])
-> SolverPackage UnresolvedPkgLoc
-> ConfiguredPackage UnresolvedPkgLoc
configureSolverPackage mapDep spkg =
@@ -504,7 +439,7 @@ configureInstallPlan solverPlan =
confPkgDeps = deps
}
where
- deps = fmap (map mapDep) (solverPkgDeps spkg)
+ deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgDeps spkg)
-- ------------------------------------------------------------
@@ -561,8 +496,7 @@ data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)
-- all the packages that are ready will now be processed and so we can consider
-- them to be in the processing state.
--
-ready :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+ready :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
ready plan =
@@ -571,13 +505,13 @@ ready plan =
where
!processing =
Processing
- (Set.fromList [ installedUnitId pkg | pkg <- readyPackages ])
- (Set.fromList [ installedUnitId pkg | PreExisting pkg <- toList plan ])
+ (Set.fromList [ nodeKey pkg | pkg <- readyPackages ])
+ (Set.fromList [ nodeKey pkg | PreExisting pkg <- toList plan ])
Set.empty
readyPackages =
[ ReadyPackage pkg
| Configured pkg <- toList plan
- , all isPreExisting (directDeps plan (installedUnitId pkg))
+ , all isPreExisting (directDeps plan (nodeKey pkg))
]
isPreExisting (PreExisting {}) = True
@@ -588,8 +522,7 @@ ready plan =
-- and return any packages that are newly in the processing state (ie ready to
-- process), along with the updated 'Processing' state.
--
-completed :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+completed :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> Processing -> UnitId
-> ([GenericReadyPackage srcpkg], Processing)
@@ -605,20 +538,19 @@ completed plan (Processing processingSet completedSet failedSet) pkgid =
-- each direct reverse dep where all direct deps are completed
newlyReady = [ dep
| dep <- revDirectDeps plan pkgid
- , all ((`Set.member` completedSet') . installedUnitId)
- (directDeps plan (installedUnitId dep))
+ , all ((`Set.member` completedSet') . nodeKey)
+ (directDeps plan (nodeKey dep))
]
processingSet' = foldl' (flip Set.insert)
(Set.delete pkgid processingSet)
- (map installedUnitId newlyReady)
+ (map nodeKey newlyReady)
processing' = Processing processingSet' completedSet' failedSet
asReadyPackage (Configured pkg) = ReadyPackage pkg
asReadyPackage _ = error "InstallPlan.completed: internal error"
-failed :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+failed :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> Processing -> UnitId
-> ([srcpkg], Processing)
@@ -634,7 +566,7 @@ failed plan (Processing processingSet completedSet failedSet) pkgid =
where
processingSet' = Set.delete pkgid processingSet
failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds
- newlyFailedIds = map installedUnitId newlyFailed
+ newlyFailedIds = map nodeKey newlyFailed
newlyFailed = fromMaybe (internalError "package not in graph")
$ Graph.revClosure (planIndex plan) [pkgid]
processing' = Processing processingSet' completedSet failedSet'
@@ -642,8 +574,7 @@ failed plan (Processing processingSet completedSet failedSet) pkgid =
asConfiguredPackage (Configured pkg) = pkg
asConfiguredPackage _ = internalError "not in configured state"
-processingInvariant :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> Processing -> Bool
processingInvariant plan (Processing processingSet completedSet failedSet) =
@@ -662,7 +593,7 @@ processingInvariant plan (Processing processingSet completedSet failedSet) =
| pkgid <- Set.toList processingSet ++ Set.toList failedSet ]
where
processingClosure = Set.fromList
- . map installedUnitId
+ . map nodeKey
. fromMaybe (internalError "processingClosure")
. Graph.revClosure (planIndex plan)
. Set.toList
@@ -683,8 +614,7 @@ processingInvariant plan (Processing processingSet completedSet failedSet) =
-- source packages in the dependency graph, albeit not necessarily exactly the
-- same ordering as that produced by 'reverseTopologicalOrder'.
--
-executionOrder :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+executionOrder :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> [GenericReadyPackage srcpkg]
executionOrder plan =
@@ -697,7 +627,7 @@ executionOrder plan =
waitForTasks processing p todo =
p : tryNewTasks processing' (todo++nextpkgs)
where
- (nextpkgs, processing') = completed plan processing (installedUnitId p)
+ (nextpkgs, processing') = completed plan processing (nodeKey p)
-- ------------------------------------------------------------
@@ -726,8 +656,7 @@ lookupBuildOutcome = Map.lookup . installedUnitId
-- can be reversed to keep going and build as many packages as possible.
--
execute :: forall m ipkg srcpkg result failure.
- (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg,
+ (IsUnit ipkg, IsUnit srcpkg,
Monad m)
=> JobControl m (UnitId, Either failure result)
-> Bool -- ^ Keep going after failure
@@ -765,7 +694,7 @@ execute jobCtl keepGoing depFailure plan installPkg =
| otherwise
= do sequence_ [ spawnJob jobCtl $ do
result <- installPkg pkg
- return (installedUnitId pkg, result)
+ return (nodeKey pkg, result)
| pkg <- newpkgs ]
waitForTasks results tasksFailed processing
@@ -797,5 +726,5 @@ execute jobCtl keepGoing depFailure plan installPkg =
(depsfailed, processing') = failed plan processing pkgid
results' = Map.insert pkgid result results `Map.union` depResults
depResults = Map.fromList
- [ (installedUnitId deppkg, Left (depFailure deppkg))
+ [ (nodeKey deppkg, Left (depFailure deppkg))
| deppkg <- depsfailed ]
diff --git a/cabal-install/Distribution/Client/PackageHash.hs b/cabal-install/Distribution/Client/PackageHash.hs
index 2f56e5672e..8468cbcbff 100644
--- a/cabal-install/Distribution/Client/PackageHash.hs
+++ b/cabal-install/Distribution/Client/PackageHash.hs
@@ -43,6 +43,7 @@ import Distribution.Text
( display )
import Distribution.Client.Types
( InstalledPackageId )
+import qualified Distribution.Solver.Types.ComponentDeps as CD
import qualified Hackage.Security.Client as Sec
@@ -133,6 +134,7 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
--
data PackageHashInputs = PackageHashInputs {
pkgHashPkgId :: PackageId,
+ pkgHashComponent :: Maybe CD.Component,
pkgHashSourceHash :: PackageSourceHash,
pkgHashDirectDeps :: Set InstalledPackageId,
pkgHashOtherConfig :: PackageHashConfigInputs
@@ -188,6 +190,7 @@ hashPackageHashInputs = hashValue . renderPackageHashInputs
renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString
renderPackageHashInputs PackageHashInputs{
pkgHashPkgId,
+ pkgHashComponent,
pkgHashSourceHash,
pkgHashDirectDeps,
pkgHashOtherConfig =
@@ -209,6 +212,7 @@ renderPackageHashInputs PackageHashInputs{
-- use the config file infrastructure so it can be read back in again.
LBS.pack $ unlines $ catMaybes
[ entry "pkgid" display pkgHashPkgId
+ , mentry "component" show pkgHashComponent
, entry "src" showHashValue pkgHashSourceHash
, entry "deps" (intercalate ", " . map display
. Set.toList) pkgHashDirectDeps
@@ -239,6 +243,7 @@ renderPackageHashInputs PackageHashInputs{
]
where
entry key format value = Just (key ++ ": " ++ format value)
+ mentry key format value = fmap (\v -> key ++ ": " ++ format v) value
opt key def format value
| value == def = Nothing
| otherwise = entry key format value
diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs
index a74e8b5616..e1749044b8 100644
--- a/cabal-install/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/Distribution/Client/ProjectBuilding.hs
@@ -1,12 +1,16 @@
{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns,
DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoMonoLocalBinds #-}
+{-# LANGUAGE ConstraintKinds #-}
-- |
--
module Distribution.Client.ProjectBuilding (
-- * Dry run phase
BuildStatus(..),
+ buildStatusToString,
BuildStatusMap,
BuildStatusRebuild(..),
BuildReason(..),
@@ -26,12 +30,13 @@ import Distribution.Client.PackageHash (renderPackageHashInputs)
import Distribution.Client.RebuildMonad
import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.Types
hiding (BuildOutcomes, BuildOutcome,
BuildResult(..), BuildFailure(..))
import Distribution.Client.InstallPlan
- ( GenericInstallPlan, GenericPlanPackage )
+ ( GenericInstallPlan, GenericPlanPackage, IsUnit )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.DistDirLayout
import Distribution.Client.FileMonitor
@@ -44,10 +49,6 @@ import Distribution.Client.Setup (filterConfigureFlags)
import Distribution.Client.SrcDist (allPackageSourceFiles)
import Distribution.Client.Utils (removeExistingFile)
-import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
-import Distribution.Solver.Types.PackageFixedDeps
-
import Distribution.Package hiding (InstalledPackageId, installedPackageId)
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as Installed
@@ -64,6 +65,7 @@ import Distribution.Version
import Distribution.Verbosity
import Distribution.Text
import Distribution.ParseUtils ( showPWarning )
+import Distribution.Compat.Graph (IsNode(..))
import Data.Map (Map)
import qualified Data.Map as Map
@@ -162,6 +164,13 @@ data BuildStatus =
-- and it does not need to be built.
| BuildStatusUpToDate BuildResult
+buildStatusToString :: BuildStatus -> String
+buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting"
+buildStatusToString BuildStatusDownload = "BuildStatusDownload"
+buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp
+buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp
+buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate"
+
-- | For a package that is going to be built or rebuilt, the state it's in now.
--
-- So again, this tells us why a package needs to be rebuilt and what build
@@ -229,10 +238,12 @@ buildStatusRequiresBuild _ = True
-- the 'ElaboratedInstallPlan' with packages switched to the
-- 'InstallPlan.Installed' state when we find that they're already up to date.
--
-rebuildTargetsDryRun :: DistDirLayout
+rebuildTargetsDryRun :: Verbosity
+ -> DistDirLayout
+ -> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> IO (ElaboratedInstallPlan, BuildStatusMap)
-rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do
+rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \installPlan -> do
-- Do the various checks to work out the 'BuildStatus' of each package
pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg
@@ -241,17 +252,18 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do
-- 'InstallPlan.Installed'.
let installPlan' = improveInstallPlanWithUpToDatePackages
installPlan pkgsBuildStatus
+ debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
return (installPlan', pkgsBuildStatus)
where
dryRunPkg :: ElaboratedPlanPackage
- -> ComponentDeps [BuildStatus]
+ -> [BuildStatus]
-> IO BuildStatus
dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
return BuildStatusPreExisting
dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
- mloc <- checkFetched (pkgSourceLocation pkg)
+ mloc <- checkFetched (pkgSourceLocation (getElaboratedPackage pkg))
case mloc of
Nothing -> return BuildStatusDownload
@@ -273,11 +285,11 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do
dryRunTarballPkg pkg depsBuildStatus tarball
dryRunTarballPkg :: ElaboratedConfiguredPackage
- -> ComponentDeps [BuildStatus]
+ -> [BuildStatus]
-> FilePath
-> IO BuildStatus
dryRunTarballPkg pkg depsBuildStatus tarball =
- case pkgBuildStyle pkg of
+ case pkgBuildStyle (getElaboratedPackage pkg) of
BuildAndInstall -> return (BuildStatusUnpack tarball)
BuildInplaceOnly -> do
-- TODO: [nice to have] use a proper file monitor rather than this dir exists test
@@ -289,7 +301,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do
srcdir = distUnpackedSrcDirectory (packageId pkg)
dryRunLocalPkg :: ElaboratedConfiguredPackage
- -> ComponentDeps [BuildStatus]
+ -> [BuildStatus]
-> FilePath
-> IO BuildStatus
dryRunLocalPkg pkg depsBuildStatus srcdir = do
@@ -307,7 +319,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do
return (BuildStatusUpToDate buildResult)
where
packageFileMonitor =
- newPackageFileMonitor distDirLayout (packageId pkg)
+ newPackageFileMonitor distDirLayout (elabDistDirParams shared pkg)
-- | A specialised traversal over the packages in an install plan.
@@ -320,12 +332,10 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do
--
foldMInstallPlanDepOrder
:: forall m ipkg srcpkg b.
- (Monad m,
- HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+ (Monad m, IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> (GenericPlanPackage ipkg srcpkg ->
- ComponentDeps [b] -> m b)
+ [b] -> m b)
-> m (Map InstalledPackageId b)
foldMInstallPlanDepOrder plan0 visit =
go Map.empty (InstallPlan.reverseTopologicalOrder plan0)
@@ -337,13 +347,13 @@ foldMInstallPlanDepOrder plan0 visit =
go !results (pkg : pkgs) = do
-- we go in the right order so the results map has entries for all deps
- let depresults :: ComponentDeps [b]
+ let depresults :: [b]
depresults =
- fmap (map (\ipkgid -> let Just result = Map.lookup ipkgid results
- in result))
- (depends pkg)
+ map (\ipkgid -> let Just result = Map.lookup ipkgid results
+ in result)
+ (nodeNeighbors pkg)
result <- visit pkg depresults
- let results' = Map.insert (installedPackageId pkg) result results
+ let results' = Map.insert (nodeKey pkg) result results
go results' pkgs
improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
@@ -362,12 +372,13 @@ improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
where
replaceWithPrePreExisting =
foldl' (\plan (ipkgid, mipkg) ->
- case mipkg of
- Just ipkg -> InstallPlan.preexisting ipkgid ipkg plan
- -- TODO: Maybe this is a little wrong, because
- -- pre-installed executables show up in the
- -- InstallPlan as source packages.
- Nothing -> plan)
+ -- TODO: A grievous hack. Better to have a special type
+ -- of entry representing pre-existing executables.
+ let stub_ipkg = Installed.emptyInstalledPackageInfo {
+ Installed.installedUnitId = ipkgid
+ }
+ ipkg = fromMaybe stub_ipkg mipkg
+ in InstallPlan.preexisting ipkgid ipkg plan)
-----------------------------
@@ -398,22 +409,22 @@ data PackageFileMonitor = PackageFileMonitor {
--
type BuildResultMisc = (DocsResult, TestsResult)
-newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor
-newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid =
+newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor
+newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams =
PackageFileMonitor {
pkgFileMonitorConfig =
- newFileMonitor (distPackageCacheFile pkgid "config"),
+ newFileMonitor (distPackageCacheFile dparams "config"),
pkgFileMonitorBuild =
FileMonitor {
- fileMonitorCacheFile = distPackageCacheFile pkgid "build",
+ fileMonitorCacheFile = distPackageCacheFile dparams "build",
fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt ->
componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,
fileMonitorCheckIfOnlyValueChanged = True
},
pkgFileMonitorReg =
- newFileMonitor (distPackageCacheFile pkgid "registration")
+ newFileMonitor (distPackageCacheFile dparams "registration")
}
-- | Helper function for 'checkPackageFileMonitorChanged',
@@ -424,8 +435,8 @@ newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid =
--
packageFileMonitorKeyValues :: ElaboratedConfiguredPackage
-> (ElaboratedConfiguredPackage, Set ComponentName)
-packageFileMonitorKeyValues pkg =
- (pkgconfig, buildComponents)
+packageFileMonitorKeyValues pkg_or_comp =
+ (pkg_or_comp_config, buildComponents)
where
-- The first part is the value used to guard (re)configuring the package.
-- That is, if this value changes then we will reconfigure.
@@ -434,17 +445,25 @@ packageFileMonitorKeyValues pkg =
-- do not affect the configure step need to be nulled out. Those parts are
-- the specific targets that we're going to build.
--
- pkgconfig = pkg {
- pkgBuildTargets = [],
- pkgReplTarget = Nothing,
- pkgBuildHaddocks = False
- }
+ pkg_or_comp_config =
+ case pkg_or_comp of
+ ElabPackage pkg -> ElabPackage $ pkg {
+ pkgBuildTargets = [],
+ pkgReplTarget = Nothing,
+ pkgBuildHaddocks = False
+ }
+ ElabComponent comp ->
+ ElabComponent $ comp {
+ elabComponentBuildTargets = [],
+ elabComponentReplTarget = Nothing,
+ elabComponentBuildHaddocks = False
+ }
-- The second part is the value used to guard the build step. So this is
-- more or less the opposite of the first part, as it's just the info about
-- what targets we're going to build.
--
- buildComponents = pkgBuildTargetWholeComponents pkg
+ buildComponents = pkgBuildTargetWholeComponents pkg_or_comp
-- | Do all the checks on whether a package has changed and thus needs either
-- rebuilding or reconfiguring and rebuilding.
@@ -452,7 +471,7 @@ packageFileMonitorKeyValues pkg =
checkPackageFileMonitorChanged :: PackageFileMonitor
-> ElaboratedConfiguredPackage
-> FilePath
- -> ComponentDeps [BuildStatus]
+ -> [BuildStatus]
-> IO (Either BuildStatusRebuild BuildResult)
checkPackageFileMonitorChanged PackageFileMonitor{..}
pkg srcdir depsBuildStatus = do
@@ -469,7 +488,7 @@ checkPackageFileMonitorChanged PackageFileMonitor{..}
-- The configChanged here includes the identity of the dependencies,
-- so depsBuildStatus is just needed for the changes in the content
-- of depencencies.
- | any buildStatusRequiresBuild (CD.flatDeps depsBuildStatus) -> do
+ | any buildStatusRequiresBuild depsBuildStatus -> do
regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()
let mreg = changedToMaybe regChanged
return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))
@@ -596,6 +615,15 @@ data BuildResult = BuildResult {
buildResultDocs :: DocsResult,
buildResultTests :: TestsResult,
buildResultLogFile :: Maybe FilePath,
+ -- | If the build was for a library, this field will be @Just@;
+ -- otherwise, it will be @Nothing@. What about internal
+ -- libraries? This never occurs, because a build result is either
+ -- for a per-component build (in which case there won't
+ -- be multiple libraries), or a package with no internal
+ -- libraries (internal libraries with Custom setups are NOT
+ -- supported, and even if they were supported, we could
+ -- assume the Cabal library version was recent enough to
+ -- support per-component build.).
buildResultLibInfo :: Maybe InstalledPackageInfo
}
deriving Show
@@ -656,8 +684,8 @@ rebuildTargets verbosity
cacheLock <- newLock -- serialise access to setup exe cache
--TODO: [code cleanup] eliminate setup exe cache
- createDirectoryIfMissingVerbose verbosity False distBuildRootDirectory
- createDirectoryIfMissingVerbose verbosity False distTempDirectory
+ createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
+ createDirectoryIfMissingVerbose verbosity True distTempDirectory
mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
-- Before traversing the install plan, pre-emptively find all packages that
@@ -690,7 +718,8 @@ rebuildTargets verbosity
packageDBsToUse = -- all the package dbs we may need to create
(Set.toList . Set.fromList)
[ pkgdb
- | InstallPlan.Configured pkg <- InstallPlan.toList installPlan
+ | InstallPlan.Configured pkg_or_comp <- InstallPlan.toList installPlan
+ , let pkg = getElaboratedPackage pkg_or_comp
, (pkgdb:_) <- map reverse [ pkgBuildPackageDBStack pkg,
pkgRegisterPackageDBStack pkg,
pkgSetupPackageDBStack pkg ]
@@ -726,6 +755,7 @@ rebuildTarget verbosity
BuildStatusUpToDate {} -> unexpectedState
where
unexpectedState = error "rebuildTarget: unexpected package status"
+ backing_pkg = getElaboratedPackage pkg
downloadPhase = do
downsrcloc <- annotateFailureNoLog DownloadFailed $
@@ -738,10 +768,10 @@ rebuildTarget verbosity
unpackTarballPhase tarball =
withTarballLocalDirectory
verbosity distDirLayout tarball
- (packageId pkg) (pkgBuildStyle pkg)
- (pkgDescriptionOverride pkg) $
+ (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (pkgBuildStyle backing_pkg)
+ (pkgDescriptionOverride backing_pkg) $
- case pkgBuildStyle pkg of
+ case pkgBuildStyle backing_pkg of
BuildAndInstall -> buildAndInstall
BuildInplaceOnly -> buildInplace buildStatus
where
@@ -752,11 +782,11 @@ rebuildTarget verbosity
-- would only start from download or unpack phases.
--
rebuildPhase buildStatus srcdir =
- assert (pkgBuildStyle pkg == BuildInplaceOnly) $
+ assert (pkgBuildStyle backing_pkg == BuildInplaceOnly) $
buildInplace buildStatus srcdir builddir
where
- builddir = distBuildDirectory (packageId pkg)
+ builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg)
buildAndInstall srcdir builddir =
buildAndInstallUnpackedPackage
@@ -804,10 +834,11 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
pkgsToDownload body
where
pkgsToDownload =
- [ pkgSourceLocation pkg
- | InstallPlan.Configured pkg
+ ordNub $
+ [ pkgSourceLocation (getElaboratedPackage pkg_or_comp)
+ | InstallPlan.Configured pkg_or_comp
<- InstallPlan.reverseTopologicalOrder installPlan
- , let ipkgid = installedPackageId pkg
+ , let ipkgid = installedPackageId pkg_or_comp
Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus
, BuildStatusDownload <- [pkgBuildStatus]
]
@@ -820,9 +851,9 @@ waitAsyncPackageDownload :: Verbosity
-> AsyncFetchMap
-> ElaboratedConfiguredPackage
-> IO DownloadedSourceLocation
-waitAsyncPackageDownload verbosity downloadMap pkg = do
+waitAsyncPackageDownload verbosity downloadMap pkg_or_comp = do
pkgloc <- waitAsyncFetchPackage verbosity downloadMap
- (pkgSourceLocation pkg)
+ (pkgSourceLocation (getElaboratedPackage pkg_or_comp))
case downloadedSourceLocation pkgloc of
Just loc -> return loc
Nothing -> fail "waitAsyncPackageDownload: unexpected source location"
@@ -849,12 +880,15 @@ withTarballLocalDirectory
-> DistDirLayout
-> FilePath
-> PackageId
+ -> DistDirParams
-> BuildStyle
-> Maybe CabalFileText
- -> (FilePath -> FilePath -> IO a)
+ -> (FilePath -> -- Source directory
+ FilePath -> -- Build directory
+ IO a)
-> IO a
withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
- tarball pkgid buildstyle pkgTextOverride
+ tarball pkgid dparams buildstyle pkgTextOverride
buildPkg =
case buildstyle of
-- In this case we make a temp dir, unpack the tarball to there and
@@ -874,15 +908,15 @@ withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
BuildInplaceOnly -> do
let srcrootdir = distUnpackedSrcRootDirectory
srcdir = distUnpackedSrcDirectory pkgid
- builddir = distBuildDirectory pkgid
+ builddir = distBuildDirectory dparams
-- TODO: [nice to have] use a proper file monitor rather than this dir exists test
exists <- doesDirectoryExist srcdir
unless exists $ do
- createDirectoryIfMissingVerbose verbosity False srcrootdir
+ createDirectoryIfMissingVerbose verbosity True srcrootdir
unpackPackageTarball verbosity tarball srcrootdir
pkgid pkgTextOverride
moveTarballShippedDistDirectory verbosity distDirLayout
- srcrootdir pkgid
+ srcrootdir pkgid dparams
buildPkg srcdir builddir
@@ -928,9 +962,9 @@ unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
-- system, though we'll still need to keep this hack for older packages.
--
moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout
- -> FilePath -> PackageId -> IO ()
+ -> FilePath -> PackageId -> DistDirParams -> IO ()
moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
- parentdir pkgid = do
+ parentdir pkgid dparams = do
distDirExists <- doesDirectoryExist tarballDistDir
when distDirExists $ do
debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"
@@ -939,7 +973,7 @@ moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
renameDirectory tarballDistDir targetDistDir
where
tarballDistDir = parentdir </> display pkgid </> "dist"
- targetDistDir = distBuildDirectory pkgid
+ targetDistDir = distBuildDirectory dparams
buildAndInstallUnpackedPackage :: Verbosity
@@ -964,7 +998,7 @@ buildAndInstallUnpackedPackage verbosity
rpkg@(ReadyPackage pkg)
srcdir builddir = do
- createDirectoryIfMissingVerbose verbosity False builddir
+ createDirectoryIfMissingVerbose verbosity True builddir
initLogFile
--TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like
@@ -977,15 +1011,20 @@ buildAndInstallUnpackedPackage verbosity
--TODO: [required feature] docs and tests
--TODO: [required feature] sudo re-exec
+ let dispname = case pkg of
+ ElabPackage _ -> display pkgid
+ ElabComponent comp -> display pkgid ++ " "
+ ++ maybe "custom" display (elabComponentName comp)
+
-- Configure phase
when isParallelBuild $
- notice verbosity $ "Configuring " ++ display pkgid ++ "..."
+ notice verbosity $ "Configuring " ++ dispname ++ "..."
annotateFailure mlogFile ConfigureFailed $
- setup configureCommand configureFlags
+ setup' configureCommand configureFlags configureArgs
-- Build phase
when isParallelBuild $
- notice verbosity $ "Building " ++ display pkgid ++ "..."
+ notice verbosity $ "Building " ++ dispname ++ "..."
annotateFailure mlogFile BuildFailed $
setup buildCommand buildFlags
@@ -1003,7 +1042,7 @@ buildAndInstallUnpackedPackage verbosity
setup Cabal.copyCommand copyFlags
LBS.writeFile
- (InstallDirs.prefix (pkgInstallDirs pkg) </> "cabal-hash.txt") $
+ (InstallDirs.prefix (elabInstallDirs pkg) </> "cabal-hash.txt") $
(renderPackageHashInputs (packageHashInputs pkgshared pkg))
-- here's where we could keep track of the installed files ourselves if
@@ -1014,7 +1053,7 @@ buildAndInstallUnpackedPackage verbosity
-- then when it's done, move it to its final location, to reduce problems
-- with installs failing half-way. Could also register and then move.
- if pkgRequiresRegistration pkg
+ if elabRequiresRegistration pkg
then do
-- We register ourselves rather than via Setup.hs. We need to
-- grab and modify the InstalledPackageInfo. We decide what
@@ -1025,7 +1064,7 @@ buildAndInstallUnpackedPackage verbosity
criticalSection registerLock $
Cabal.registerPackage verbosity compiler progdb
HcPkg.MultiInstance
- (pkgRegisterPackageDBStack pkg) ipkg
+ (pkgRegisterPackageDBStack (getElaboratedPackage pkg)) ipkg
return (Just ipkg)
else return Nothing
@@ -1050,6 +1089,7 @@ buildAndInstallUnpackedPackage verbosity
configureFlags v = flip filterConfigureFlags v $
setupHsConfigureFlags rpkg pkgshared
verbosity builddir
+ configureArgs = setupHsConfigureArgs pkg
buildCommand = Cabal.buildCommand defaultProgramConfiguration
buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir
@@ -1070,13 +1110,16 @@ buildAndInstallUnpackedPackage verbosity
isParallelBuild cacheLock
setup :: CommandUI flags -> (Version -> flags) -> IO ()
- setup cmd flags =
+ setup cmd flags = setup' cmd flags []
+
+ setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()
+ setup' cmd flags args =
withLogging $ \mLogFileHandle ->
setupWrapper
verbosity
scriptOptions { useLoggingHandle = mLogFileHandle }
- (Just (pkgDescription pkg))
- cmd flags []
+ (Just (pkgDescription (getElaboratedPackage pkg)))
+ cmd flags args
mlogFile :: Maybe FilePath
mlogFile =
@@ -1123,14 +1166,14 @@ buildInplaceUnpackedPackage verbosity
--TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here
-- builddir is not enough, we also need the per-package cachedir
- createDirectoryIfMissingVerbose verbosity False builddir
- createDirectoryIfMissingVerbose verbosity False (distPackageCacheDirectory pkgid)
+ createDirectoryIfMissingVerbose verbosity True builddir
+ createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams)
-- Configure phase
--
whenReConfigure $ do
annotateFailureNoLog ConfigureFailed $
- setup configureCommand configureFlags []
+ setup configureCommand configureFlags configureArgs
invalidatePackageRegFileMonitor packageFileMonitor
updatePackageConfigFileMonitor packageFileMonitor srcdir pkg
@@ -1159,7 +1202,7 @@ buildInplaceUnpackedPackage verbosity
mipkg <- whenReRegister $
annotateFailureNoLog InstallFailed $ do
-- Register locally
- mipkg <- if pkgRequiresRegistration pkg
+ mipkg <- if elabRequiresRegistration pkg
then do
ipkg0 <- generateInstalledPackageInfo
-- We register ourselves rather than via Setup.hs. We need to
@@ -1168,7 +1211,7 @@ buildInplaceUnpackedPackage verbosity
let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }
criticalSection registerLock $
Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance
- (pkgRegisterPackageDBStack pkg)
+ (pkgRegisterPackageDBStack (getElaboratedPackage pkg))
ipkg
return (Just ipkg)
@@ -1196,27 +1239,27 @@ buildInplaceUnpackedPackage verbosity
}
where
- pkgid = packageId rpkg
- ipkgid = installedPackageId rpkg
+ ipkgid = installedUnitId pkg
+ dparams = elabDistDirParams pkgshared pkg
isParallelBuild = buildSettingNumJobs >= 2
- packageFileMonitor = newPackageFileMonitor distDirLayout pkgid
+ packageFileMonitor = newPackageFileMonitor distDirLayout dparams
whenReConfigure action = case buildStatus of
BuildStatusConfigure _ -> action
_ -> return ()
whenRebuild action
- | null (pkgBuildTargets pkg) = return ()
+ | null (elabBuildTargets pkg) = return ()
| otherwise = action
whenRepl action
- | isNothing (pkgReplTarget pkg) = return ()
+ | isNothing (elabReplTarget pkg) = return ()
| otherwise = action
whenHaddock action
- | pkgBuildHaddocks pkg = action
+ | elabBuildHaddocks pkg = action
| otherwise = return ()
whenReRegister action = case buildStatus of
@@ -1228,6 +1271,7 @@ buildInplaceUnpackedPackage verbosity
configureFlags v = flip filterConfigureFlags v $
setupHsConfigureFlags rpkg pkgshared
verbosity builddir
+ configureArgs = setupHsConfigureArgs pkg
buildCommand = Cabal.buildCommand defaultProgramConfiguration
buildFlags _ = setupHsBuildFlags pkg pkgshared
@@ -1251,7 +1295,7 @@ buildInplaceUnpackedPackage verbosity
setup cmd flags args =
setupWrapper verbosity
scriptOptions
- (Just (pkgDescription pkg))
+ (Just (pkgDescription (getElaboratedPackage pkg)))
cmd flags args
generateInstalledPackageInfo :: IO InstalledPackageInfo
diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs
index ea50730a5a..857c93636a 100644
--- a/cabal-install/Distribution/Client/ProjectOrchestration.hs
+++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs
@@ -58,6 +58,7 @@ module Distribution.Client.ProjectOrchestration (
import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.ProjectBuilding
import Distribution.Client.Types
@@ -79,7 +80,7 @@ import qualified Distribution.PackageDescription as PD
import Distribution.PackageDescription (FlagAssignment)
import Distribution.Simple.Setup (HaddockFlags)
-import Distribution.Simple.Utils (die, notice)
+import Distribution.Simple.Utils (die, notice, debug)
import Distribution.Verbosity
import Distribution.Text
@@ -183,7 +184,7 @@ runProjectPreBuildPhase
-- This also gives us more accurate reasons for the --dry-run output.
--
(elaboratedPlan'', pkgsBuildStatus) <-
- rebuildTargetsDryRun distDirLayout
+ rebuildTargetsDryRun verbosity distDirLayout elaboratedShared
elaboratedPlan'
return ProjectBuildContext {
@@ -243,14 +244,34 @@ runProjectBuildPhase verbosity ProjectBuildContext {..} =
-- | Adjust an 'ElaboratedInstallPlan' by selecting just those parts of it
-- required to build the given user targets.
--
--- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable.
+-- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable,
+-- so that we can change the meaning of @pkgname@ to target a build or
+-- repl depending on which command is calling it.
--
-selectTargets :: PackageTarget
+-- Conceptually, every target identifies one or more roots in the
+-- 'ElaboratedInstallPlan', which we then use to determine the closure
+-- of what packages need to be built, dropping everything from
+-- 'ElaboratedInstallPlan' that is unnecessary.
+--
+-- There is a complication, however: In an ideal world, every
+-- possible target would be a node in the graph. However, it is
+-- currently not possible (and possibly not even desirable) to invoke a
+-- Setup script to build *just* one file. Similarly, it is not possible
+-- to invoke a pre Cabal-1.25 custom Setup script and build only one
+-- component. In these cases, we want to build the entire package, BUT
+-- only actually building some of the files/components. This is what
+-- 'pkgBuildTargets', 'pkgReplTarget' and 'pkgBuildHaddock' control.
+-- Arguably, these should an out-of-band mechanism rather than stored
+-- in 'ElaboratedInstallPlan', but it's what we have. We have
+-- to fiddle around with the ElaboratedConfiguredPackage roots to say
+-- what it will build.
+--
+selectTargets :: Verbosity -> PackageTarget
-> (ComponentTarget -> PackageTarget)
-> [UserBuildTarget]
-> ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
-selectTargets targetDefaultComponents targetSpecificComponent
+selectTargets verbosity targetDefaultComponents targetSpecificComponent
userBuildTargets installPlan = do
-- Match the user targets against the available targets. If no targets are
@@ -277,6 +298,7 @@ selectTargets targetDefaultComponents targetSpecificComponent
targetSpecificComponent
installPlan
buildTargets
+ debug verbosity ("buildTargets': " ++ show buildTargets')
-- Finally, prune the install plan to cover just those target packages
-- and their deps.
@@ -285,7 +307,8 @@ selectTargets targetDefaultComponents targetSpecificComponent
where
localPackages =
[ (pkgDescription pkg, pkgSourceLocation pkg)
- | InstallPlan.Configured pkg <- InstallPlan.toList installPlan ]
+ | InstallPlan.Configured pkg_or_comp <- InstallPlan.toList installPlan
+ , let pkg = getElaboratedPackage pkg_or_comp ]
--TODO: [code cleanup] is there a better way to identify local packages?
@@ -301,7 +324,8 @@ resolveAndCheckTargets targetDefaultComponents
installPlan targets =
case partitionEithers (map checkTarget targets) of
([], targets') -> Right $ Map.fromListWith (++)
- [ (ipkgid, [t]) | (ipkgid, t) <- targets' ]
+ [ (ipkgid, [t]) | (ipkgids, t) <- targets'
+ , ipkgid <- ipkgids ]
(problems, _) -> Left problems
where
-- TODO [required eventually] currently all build targets refer to packages
@@ -342,16 +366,20 @@ resolveAndCheckTargets targetDefaultComponents
= Left (BuildTargetNotInProject (buildTargetPackage t))
- projAllPkgs, projLocalPkgs :: Map PackageName InstalledPackageId
+ -- NB: It's a list of 'InstalledPackageId', because each component
+ -- in the install plan from a single package needs to be associated with
+ -- the same 'PackageName'.
+ projAllPkgs, projLocalPkgs :: Map PackageName [InstalledPackageId]
projAllPkgs =
- Map.fromList
- [ (packageName pkg, installedPackageId pkg)
+ Map.fromListWith (++)
+ [ (packageName pkg, [installedPackageId pkg])
| pkg <- InstallPlan.toList installPlan ]
projLocalPkgs =
- Map.fromList
- [ (packageName pkg, installedPackageId pkg)
- | InstallPlan.Configured pkg <- InstallPlan.toList installPlan
+ Map.fromListWith (++)
+ [ (packageName pkg, [installedPackageId pkg_or_comp])
+ | InstallPlan.Configured pkg_or_comp <- InstallPlan.toList installPlan
+ , let pkg = getElaboratedPackage pkg_or_comp
, case pkgSourceLocation pkg of
LocalUnpackedPackage _ -> True; _ -> False
--TODO: [code cleanup] is there a better way to identify local packages?
@@ -418,18 +446,25 @@ printPlan verbosity
wouldWill | buildSettingDryRun = "would"
| otherwise = "will"
- showPkg pkg = display (packageId pkg)
+ showPkg (ReadyPackage (ElabPackage pkg)) = display (packageId pkg)
+ showPkg (ReadyPackage (ElabComponent comp)) =
+ display (packageId (elabComponentPackage comp)) ++
+ " (" ++ maybe "custom" display (elabComponentName comp) ++ ")"
showPkgAndReason :: ElaboratedReadyPackage -> String
- showPkgAndReason (ReadyPackage pkg) =
- display (packageId pkg) ++
- showTargets pkg ++
+ showPkgAndReason (ReadyPackage pkg_or_comp) =
+ display (installedUnitId pkg_or_comp) ++
+ (case pkg_or_comp of
+ ElabPackage _ -> showTargets pkg ++ showStanzas pkg
+ ElabComponent comp ->
+ " (" ++ maybe "custom" display (elabComponentName comp) ++ ")") ++
showFlagAssignment (nonDefaultFlags pkg) ++
- showStanzas pkg ++
- let buildStatus = pkgsBuildStatus Map.! installedPackageId pkg in
+ let buildStatus = pkgsBuildStatus Map.! installedPackageId pkg_or_comp in
" (" ++ showBuildStatus buildStatus ++ ")"
+ where
+ pkg = getElaboratedPackage pkg_or_comp
- nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
+ nonDefaultFlags :: ElaboratedPackage -> FlagAssignment
nonDefaultFlags pkg = pkgFlagAssignment pkg \\ pkgFlagDefaults pkg
showStanzas pkg = concat
diff --git a/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/Distribution/Client/ProjectPlanOutput.hs
index 2dc10699c2..0d5e6a141c 100644
--- a/cabal-install/Distribution/Client/ProjectPlanOutput.hs
+++ b/cabal-install/Distribution/Client/ProjectPlanOutput.hs
@@ -9,8 +9,6 @@ module Distribution.Client.ProjectPlanOutput (
) where
import Distribution.Client.ProjectPlanning.Types
- ( ElaboratedInstallPlan, ElaboratedConfiguredPackage(..)
- , ElaboratedSharedConfig(..) )
import Distribution.Client.DistDirLayout
import qualified Distribution.Client.InstallPlan as InstallPlan
@@ -66,27 +64,46 @@ encodePlanAsJson elaboratedInstallPlan _elaboratedSharedConfig =
J.object
[ "type" J..= J.String "pre-existing"
, "id" J..= jdisplay (installedUnitId ipi)
- , "components" J..= J.object
- [ "lib" J..= J.object [ "depends" J..= map jdisplay (installedDepends ipi) ] ]
+ , "depends" J..= map jdisplay (installedDepends ipi)
]
- -- ecp :: ElaboratedConfiguredPackage
- toJ (InstallPlan.Configured ecp) =
+ -- pkg :: ElaboratedPackage
+ toJ (InstallPlan.Configured (ElabPackage pkg)) =
J.object
[ "type" J..= J.String "configured"
- , "id" J..= (jdisplay . installedUnitId) ecp
+ , "id" J..= (jdisplay . installedUnitId) pkg
, "components" J..= components
+ , "depends" J..= map (jdisplay . confInstId) flat_deps
, "flags" J..= J.object [ fn J..= v
- | (PD.FlagName fn,v) <- pkgFlagAssignment ecp ]
+ | (PD.FlagName fn,v) <-
+ pkgFlagAssignment pkg ]
]
where
+ flat_deps = ordNub (ComponentDeps.flatDeps (pkgDependencies pkg))
components = J.object
[ comp2str c J..= J.object
[ "depends" J..= map (jdisplay . installedUnitId) v ]
- | (c,v) <- ComponentDeps.toList (pkgDependencies ecp) ]
+ -- NB: does NOT contain order-only dependencies
+ | (c,v) <- ComponentDeps.toList (pkgDependencies pkg) ]
+
+ -- ecp :: ElaboratedConfiguredPackage
+ toJ (InstallPlan.Configured (ElabComponent comp)) =
+ J.object
+ [ "type" J..= J.String "configured-component"
+ , "id" J..= (jdisplay . installedUnitId) comp
+ , "name" J..= J.String (comp2str (elabComponent comp))
+ , "flags" J..= J.object [ fn J..= v
+ | (PD.FlagName fn,v) <-
+ pkgFlagAssignment pkg ]
+ -- NB: does NOT contain order-only dependencies
+ , "depends" J..= map (jdisplay . installedUnitId) (elabComponentDependencies comp)
+ ]
+ where
+ pkg = elabComponentPackage comp
-- TODO: maybe move this helper to "ComponentDeps" module?
-- Or maybe define a 'Text' instance?
+ comp2str :: ComponentDeps.Component -> String
comp2str c = case c of
ComponentDeps.ComponentLib -> "lib"
ComponentDeps.ComponentSubLib s -> "lib:" <> s
diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs
index 704c88da99..87db0e9ba6 100644
--- a/cabal-install/Distribution/Client/ProjectPlanning.hs
+++ b/cabal-install/Distribution/Client/ProjectPlanning.hs
@@ -1,4 +1,7 @@
{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoMonoLocalBinds #-}
-- | Planning how to build everything in a project.
--
@@ -31,6 +34,7 @@ module Distribution.Client.ProjectPlanning (
-- * Setup.hs CLI flags for building
setupHsScriptOptions,
setupHsConfigureFlags,
+ setupHsConfigureArgs,
setupHsBuildFlags,
setupHsBuildArgs,
setupHsReplFlags,
@@ -71,7 +75,6 @@ import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
-import Distribution.Solver.Types.PackageFixedDeps
import Distribution.Solver.Types.PkgConfigDb
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
@@ -108,13 +111,12 @@ import Distribution.Verbosity
import Distribution.Text
import qualified Distribution.Compat.Graph as Graph
+import Distribution.Compat.Graph(IsNode(..))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
-import qualified Data.Graph as OldGraph
-import qualified Data.Tree as Tree
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
@@ -179,15 +181,18 @@ import System.Directory (doesDirectoryExist)
-- data BuildStyle =
--- | Check that an 'ElaboratedConfiguredPackage' actually makes
+-- | Check that an 'ElaboratedPackage' actually makes
-- sense under some 'ElaboratedSharedConfig'.
-sanityCheckElaboratedConfiguredPackage :: ElaboratedSharedConfig
- -> ElaboratedConfiguredPackage
- -> a
- -> a
-sanityCheckElaboratedConfiguredPackage sharedConfig
- pkg@ElaboratedConfiguredPackage{..}
- ret =
+--
+-- TODO: I guess maybe there's some 'ElaboratedComponent' sanity
+-- check one could also do
+sanityCheckElaboratedPackage :: ElaboratedSharedConfig
+ -> ElaboratedPackage
+ -> a
+ -> a
+sanityCheckElaboratedPackage sharedConfig
+ pkg@ElaboratedPackage{..}
+ ret =
-- we should only have enabled stanzas that actually can be built
-- (according to the solver)
@@ -208,7 +213,7 @@ sanityCheckElaboratedConfiguredPackage sharedConfig
-- the elaborated configured package
. assert (pkgBuildStyle == BuildInplaceOnly ||
installedPackageId pkg == hashedInstalledPackageId
- (packageHashInputs sharedConfig pkg))
+ (packageHashInputs sharedConfig (ElabPackage pkg)))
-- either a package is built inplace, or we are not attempting to
-- build any test suites or benchmarks (we never build these
@@ -282,6 +287,7 @@ rebuildInstallPlan verbosity
elaboratedShared) <- phaseElaboratePlan projectConfigTransient
compilerEtc
solverPlan localPackages
+
return (elaboratedPlan, elaboratedShared, projectConfig)
-- The improved plan changes each time we install something, whereas
@@ -310,8 +316,8 @@ rebuildInstallPlan verbosity
phaseReadProjectConfig = do
liftIO $ do
info verbosity "Project settings changed, reconfiguring..."
- createDirectoryIfMissingVerbose verbosity False distDirectory
- createDirectoryIfMissingVerbose verbosity False distProjectCacheDirectory
+ createDirectoryIfMissingVerbose verbosity True distDirectory
+ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
projectConfig <- readProjectConfig verbosity projectRootDir
@@ -517,25 +523,26 @@ rebuildInstallPlan verbosity
getPackageSourceHashes verbosity withRepoCtx solverPlan
defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler
- return $
- elaborateInstallPlan
- platform compiler progdb
- distDirLayout
- cabalDirLayout
- solverPlan
- localPackages
- sourcePackageHashes
- defaultInstallDirs
- projectConfigShared
- projectConfigLocalPackages
- (getMapMappend projectConfigSpecificPackage)
+ let (elaboratedPlan, elaboratedShared) =
+ elaborateInstallPlan
+ platform compiler progdb
+ distDirLayout
+ cabalDirLayout
+ solverPlan
+ localPackages
+ sourcePackageHashes
+ defaultInstallDirs
+ projectConfigShared
+ projectConfigLocalPackages
+ (getMapMappend projectConfigSpecificPackage)
+ liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan)
+ return (elaboratedPlan, elaboratedShared)
where
withRepoCtx = projectConfigWithSolverRepoContext verbosity
cabalPackageCacheDirectory
projectConfigShared
projectConfigBuildOnly
-
-- Update the files we maintain that reflect our current build environment.
-- In particular we maintain a JSON representation of the elaborated
-- install plan.
@@ -577,6 +584,7 @@ rebuildInstallPlan verbosity
let improvedPlan = improveInstallPlanWithPreExistingPackages
storePkgIndex
elaboratedPlan
+ liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan)
return improvedPlan
where
@@ -658,7 +666,7 @@ createPackageDBIfMissing verbosity compiler progdb
(SpecificPackageDB dbPath) = do
exists <- liftIO $ Cabal.doesPackageDBExist dbPath
unless exists $ do
- createDirectoryIfMissingVerbose verbosity False (takeDirectory dbPath)
+ createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
Cabal.createPackageDB verbosity compiler progdb False dbPath
createPackageDBIfMissing _ _ _ _ = return ()
@@ -1011,15 +1019,95 @@ elaborateInstallPlan platform compiler compilerprogdb
flip InstallPlan.fromSolverInstallPlan solverPlan $ \mapDep planpkg ->
case planpkg of
SolverInstallPlan.PreExisting pkg _ ->
- InstallPlan.PreExisting pkg
+ [InstallPlan.PreExisting pkg]
SolverInstallPlan.Configured pkg ->
- InstallPlan.Configured
- (elaborateSolverPackage mapDep pkg)
-
- elaborateSolverPackage :: (SolverId -> ConfiguredId)
+ map InstallPlan.Configured (elaborateAndExpandSolverPackage mapDep pkg)
+
+ elaborateAndExpandSolverPackage
+ :: (SolverId -> [ElaboratedPlanPackage])
+ -> SolverPackage UnresolvedPkgLoc
+ -> [ElaboratedConfiguredPackage]
+ elaborateAndExpandSolverPackage mapDep spkg
+ | eligible
+ , Right g <- comps_graph
+ = map ElabComponent (snd (mapAccumL buildComponent Map.empty g))
+ | otherwise
+ = [ElabPackage pkg]
+ where
+ pkg = elaborateSolverPackage mapDep spkg
+ pkgid = pkgSourceId pkg
+ pd = pkgDescription pkg
+ eligible
+ -- TODO
+ -- At this point in time, only non-Custom setup scripts
+ -- are supported. Implementing per-component builds with
+ -- Custom would require us to create a new 'ElabSetup'
+ -- type, and teach all of the code paths how to handle it.
+ -- Once you've implemented that, delete this guard.
+ | fromMaybe PD.Custom (PD.buildType pd) == PD.Custom
+ = False
+ -- Only non-Custom or sufficiently recent Custom
+ -- scripts can be expanded.
+ | otherwise
+ = (fromMaybe PD.Custom (PD.buildType pd) /= PD.Custom
+ -- This is when we started distributing dependencies
+ -- per component (instead of glomming them altogether
+ -- and distributing to everything.) I didn't feel
+ -- like implementing the legacy behavior.
+ && PD.specVersion pd >= Version [1,7,1] []
+ )
+ || PD.specVersion pd >= Version [2,0,0] []
+ internalPkgSet = pkgInternalPackages pkg
+ comps_graph = Cabal.mkComponentsGraph (pkgEnabled pkg) pd internalPkgSet
+
+ buildComponent :: Map ComponentName ConfiguredId
+ -> (Cabal.Component, [Cabal.ComponentName])
+ -> (Map ComponentName ConfiguredId, ElaboratedComponent)
+ buildComponent internal_map (comp, cdeps) =
+ (internal_map', ecomp)
+ where
+ cname = Cabal.componentName comp
+ cname' = CD.componentNameToComponent cname
+ ecomp = ElaboratedComponent {
+ elabComponent = cname',
+ elabComponentName = Just cname,
+ elabComponentId = cid,
+ elabComponentPackage = pkg,
+ elabComponentDependencies = deps,
+ -- TODO: track dependencies on executables
+ elabComponentExeDependencies = [],
+ -- These are filled in later
+ elabComponentBuildTargets = [],
+ elabComponentReplTarget = Nothing,
+ elabComponentBuildHaddocks = False
+ }
+ cid = case pkgBuildStyle pkg of
+ BuildInplaceOnly ->
+ mkUnitId $
+ display pkgid ++ "-inplace" ++
+ (case Cabal.componentNameString cname of
+ Nothing -> ""
+ Just s -> "-" ++ s)
+ BuildAndInstall ->
+ -- TODO: change these types
+ hashedInstalledPackageId
+ (packageHashInputs
+ elaboratedSharedConfig
+ (ElabComponent ecomp)) -- knot tied
+ confid = ConfiguredId pkgid cid
+ external_deps = CD.select (== cname') (pkgDependencies pkg)
+ internal_map' = Map.insert cname confid internal_map
+ -- TODO: Custom setup dep.
+ internal_deps = [ confid'
+ | cdep <- cdeps
+ , Just confid' <- [Map.lookup cdep internal_map] ]
+ deps = external_deps ++ internal_deps
+
+
+ elaborateSolverPackage :: (SolverId -> [ElaboratedPlanPackage])
-> SolverPackage UnresolvedPkgLoc
- -> ElaboratedConfiguredPackage
+ -> ElaboratedPackage
elaborateSolverPackage
mapDep
pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride)
@@ -1030,11 +1118,15 @@ elaborateInstallPlan platform compiler compilerprogdb
-- pkgInstalledId, which is calculated by hashing many
-- of the other fields of the elaboratedPackage.
--
- elaboratedPackage = ElaboratedConfiguredPackage {..}
+ elaboratedPackage = ElaboratedPackage {..}
- deps = fmap (map elaborateSolverId) deps0
+ deps = fmap (concatMap elaborateSolverId) deps0
- elaborateSolverId = mapDep
+ elaborateSolverId = map configuredId . filter is_lib . mapDep
+ where is_lib (InstallPlan.PreExisting _) = True
+ is_lib (InstallPlan.Configured (ElabPackage _)) = True
+ is_lib (InstallPlan.Configured (ElabComponent comp))
+ = elabComponent comp == CD.ComponentLib
pkgInstalledId
| shouldBuildInplaceOnly pkg
@@ -1045,7 +1137,7 @@ elaborateInstallPlan platform compiler compilerprogdb
hashedInstalledPackageId
(packageHashInputs
elaboratedSharedConfig
- elaboratedPackage) -- recursive use of elaboratedPackage
+ (ElabPackage elaboratedPackage)) -- recursive use of elaboratedPackage
| otherwise
= error $ "elaborateInstallPlan: non-inplace package "
@@ -1056,15 +1148,18 @@ elaborateInstallPlan platform compiler compilerprogdb
pkgSourceId = pkgid
pkgDescription = let Right (desc, _) =
PD.finalizePD
- flags enabled (const True)
+ flags pkgEnabled (const True)
platform (compilerInfo compiler)
[] gdesc
in desc
+ pkgInternalPackages = Cabal.getInternalPackages gdesc
pkgFlagAssignment = flags
pkgFlagDefaults = [ (Cabal.flagName flag, Cabal.flagDefault flag)
| flag <- PD.genPackageFlags gdesc ]
pkgDependencies = deps
- enabled = enableStanzas stanzas
+ -- TODO: add support for dependencies on executables
+ pkgExeDependencies = CD.empty
+ pkgEnabled = enableStanzas stanzas
pkgStanzasAvailable = Set.fromList stanzas
pkgStanzasRequested =
-- NB: even if a package stanza is requested, if the package
@@ -1306,7 +1401,6 @@ elaborateInstallPlan platform compiler compilerprogdb
-- + vanilla libs & exes, exe needs lib, recursive
-- + ghci or shared lib needed by TH, recursive, ghc version dependent
-
---------------------------
-- Build targets
--
@@ -1319,9 +1413,9 @@ elaborateInstallPlan platform compiler compilerprogdb
--TODO: this needs to report some user target/config errors
-elaboratePackageTargets :: ElaboratedConfiguredPackage -> [PackageTarget]
+elaboratePackageTargets :: ElaboratedPackage -> [PackageTarget]
-> ([ComponentTarget], Maybe ComponentTarget, Bool)
-elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =
+elaboratePackageTargets ElaboratedPackage{..} targets =
let buildTargets = nubComponentTargets
. map compatSubComponentTargets
. concatMap elaborateBuildTarget
@@ -1389,9 +1483,11 @@ elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =
(t:_) -> [t]
[] -> ts
-
pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool
-pkgHasEphemeralBuildTargets pkg =
+-- TODO: Arguably ElabComponent should have its own notes about
+-- subtargets / repl targets rather than cribbing it off
+-- ElaboratedPackage.
+pkgHasEphemeralBuildTargets (getElaboratedPackage -> pkg) =
isJust (pkgReplTarget pkg)
|| (not . null) [ () | ComponentTarget _ subtarget <- pkgBuildTargets pkg
, subtarget /= WholeComponent ]
@@ -1402,9 +1498,11 @@ pkgHasEphemeralBuildTargets pkg =
--
pkgBuildTargetWholeComponents :: ElaboratedConfiguredPackage
-> Set ComponentName
-pkgBuildTargetWholeComponents pkg =
+pkgBuildTargetWholeComponents (ElabPackage pkg) =
Set.fromList
[ cname | ComponentTarget cname WholeComponent <- pkgBuildTargets pkg ]
+pkgBuildTargetWholeComponents (ElabComponent comp) =
+ Set.fromList $ maybe [] (:[]) (elabComponentName comp)
------------------------------------------------------------------------------
@@ -1419,14 +1517,43 @@ pkgBuildTargetWholeComponents pkg =
pruneInstallPlanToTargets :: Map InstalledPackageId [PackageTarget]
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets perPkgTargetsMap =
- either (\_ -> assert False undefined) id
- . InstallPlan.new (IndependentGoals False)
+ InstallPlan.new (IndependentGoals False)
. Graph.fromList
-- We have to do this in two passes
. pruneInstallPlanPass2
. pruneInstallPlanPass1 perPkgTargetsMap
. InstallPlan.toList
+-- | This is a temporary data type, where we temporarily
+-- override the graph dependencies of an 'ElaboratedPackage',
+-- so we can take a closure over them. We'll throw out the
+-- overriden dependencies when we're done so it's strictly temporary.
+--
+-- This rigamarole is totally unnecessary for 'ElaboratedComponent',
+-- where we don't need to avoid configuring a test suite; it always
+-- is configured separately.
+data PrunedPackage
+ = PrunedPackage ElaboratedPackage [InstalledPackageId]
+ | PrunedComponent ElaboratedComponent
+
+instance Package PrunedPackage where
+ packageId (PrunedPackage pkg _) = packageId pkg
+ packageId (PrunedComponent comp) = packageId comp
+
+instance HasUnitId PrunedPackage where
+ installedUnitId = nodeKey
+
+instance IsNode PrunedPackage where
+ type Key PrunedPackage = InstalledPackageId
+ nodeKey (PrunedPackage pkg _) = nodeKey pkg
+ nodeKey (PrunedComponent comp) = nodeKey comp
+ nodeNeighbors (PrunedPackage _ deps) = deps
+ nodeNeighbors (PrunedComponent comp) = nodeNeighbors comp
+
+fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage
+fromPrunedPackage (PrunedPackage pkg _) = ElabPackage pkg
+fromPrunedPackage (PrunedComponent comp) = ElabComponent comp
+
-- | The first pass does three things:
--
-- * Set the build targets based on the user targets (but not rev deps yet).
@@ -1440,22 +1567,62 @@ pruneInstallPlanPass1 :: Map InstalledPackageId [PackageTarget]
-> [ElaboratedPlanPackage]
-> [ElaboratedPlanPackage]
pruneInstallPlanPass1 perPkgTargetsMap pkgs =
- map fst $
- dependencyClosure
- (installedPackageId . fst) -- the pkg id
- snd -- the pruned deps
- [ (pkg', pruneOptionalDependencies pkg')
- | pkg <- pkgs
- , let pkg' = mapConfiguredPackage
- (pruneOptionalStanzas . setBuildTargets) pkg
- ]
- (Map.keys perPkgTargetsMap)
+ map (mapConfiguredPackage fromPrunedPackage)
+ (fromMaybe [] $ Graph.closure g roots)
where
+ pkgs' = map (mapConfiguredPackage prune) pkgs
+ g = Graph.fromList pkgs'
+
+ prune (ElabPackage pkg) =
+ let pkg' = (pruneOptionalStanzas . setPkgBuildTargets) pkg
+ in PrunedPackage pkg' (pruneOptionalDependencies pkg')
+ prune (ElabComponent comp) = PrunedComponent (setComponentBuildTargets comp)
+
+ roots = mapMaybe find_root pkgs'
+ find_root (InstallPlan.Configured (PrunedPackage pkg _)) =
+ if not (null (pkgBuildTargets pkg)
+ && isNothing (pkgReplTarget pkg)
+ && not (pkgBuildHaddocks pkg))
+ then Just (installedUnitId pkg)
+ else Nothing
+ find_root (InstallPlan.Configured (PrunedComponent comp)) =
+ if not (null (elabComponentBuildTargets comp)
+ && isNothing (elabComponentReplTarget comp)
+ && not (elabComponentBuildHaddocks comp))
+ then Just (installedUnitId comp)
+ else Nothing
+ find_root _ = Nothing
+
+ setComponentBuildTargets comp =
+ comp {
+ elabComponentBuildTargets = buildTargets',
+ elabComponentReplTarget = replTarget',
+ elabComponentBuildHaddocks = buildHaddocks
+ }
+ where
+ -- I didn't feel like reimplementing elaboratePackageTargets,
+ -- so I just called it directly.
+ (buildTargets, replTarget, buildHaddocks)
+ = elaboratePackageTargets (elabComponentPackage comp) targets
+ -- Pare down the results for only things that are relevant
+ -- to us. This is because were sloppy when assigning targets
+ -- to IPIDs.
+ buildTargets' = mapMaybe f buildTargets
+ where f (ComponentTarget cname sub)
+ | Just cname == elabComponentName comp = Just sub
+ | otherwise = Nothing
+ replTarget' = replTarget >>= \(ComponentTarget cname sub) ->
+ if Just cname == elabComponentName comp
+ then Just sub
+ else Nothing
+ targets = fromMaybe []
+ $ Map.lookup (installedPackageId comp) perPkgTargetsMap
+
-- Elaborate and set the targets we'll build for this package. This is just
-- based on the targets from the user, not targets implied by reverse
-- dependencies. Those comes in the second pass once we know the rev deps.
--
- setBuildTargets pkg =
+ setPkgBuildTargets pkg =
pkg {
pkgBuildTargets = buildTargets,
pkgReplTarget = replTarget,
@@ -1496,18 +1663,17 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs =
-- the optional stanzas and we'll make further tweaks to the optional
-- stanzas in the next pass.
--
- pruneOptionalDependencies :: ElaboratedPlanPackage -> [InstalledPackageId]
- pruneOptionalDependencies (InstallPlan.Configured pkg) =
- (CD.flatDeps . CD.filterDeps keepNeeded) (depends pkg)
+ pruneOptionalDependencies :: ElaboratedPackage -> [InstalledPackageId]
+ pruneOptionalDependencies pkg =
+ -- TODO: do the right thing when this is a test-suite component itself
+ (CD.flatDeps . CD.filterDeps keepNeeded . fmap (map confInstId)) (pkgDependencies pkg)
where
keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas
keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas
keepNeeded _ _ = True
stanzas = pkgStanzasEnabled pkg
- pruneOptionalDependencies pkg =
- CD.flatDeps (depends pkg)
- optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage
+ optionalStanzasRequiredByTargets :: ElaboratedPackage
-> Set OptionalStanza
optionalStanzasRequiredByTargets pkg =
Set.fromList
@@ -1517,7 +1683,7 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs =
, stanza <- maybeToList (componentOptionalStanza cname)
]
- optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage
+ optionalStanzasRequestedByDefault :: ElaboratedPackage
-> Set OptionalStanza
optionalStanzasRequestedByDefault =
Map.keysSet
@@ -1536,7 +1702,7 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs =
-- all of the deps needed for the test suite, we go ahead and
-- enable it always.
optionalStanzasWithDepsAvailable :: Set InstalledPackageId
- -> ElaboratedConfiguredPackage
+ -> ElaboratedPackage
-> Set OptionalStanza
optionalStanzasWithDepsAvailable availablePkgs pkg =
Set.fromList
@@ -1586,8 +1752,18 @@ pruneInstallPlanPass2 :: [ElaboratedPlanPackage]
pruneInstallPlanPass2 pkgs =
map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs
where
- setStanzasDepsAndTargets pkg =
- pkg {
+ setStanzasDepsAndTargets (ElabComponent comp) =
+ ElabComponent $ comp {
+ elabComponentBuildTargets = elabComponentBuildTargets comp
+ ++ targetsRequiredForRevDeps
+ }
+ where
+ targetsRequiredForRevDeps =
+ [ WholeComponent
+ | installedPackageId comp `Set.member` hasReverseLibDeps
+ ]
+ setStanzasDepsAndTargets (ElabPackage pkg) =
+ ElabPackage $ pkg {
pkgStanzasEnabled = stanzas,
pkgDependencies = CD.filterDeps keepNeeded (pkgDependencies pkg),
pkgBuildTargets = pkgBuildTargets pkg ++ targetsRequiredForRevDeps
@@ -1614,15 +1790,15 @@ pruneInstallPlanPass2 pkgs =
hasReverseLibDeps :: Set InstalledPackageId
hasReverseLibDeps =
Set.fromList [ depid | pkg <- pkgs
- , depid <- CD.flatDeps (depends pkg) ]
-
+ , depid <- nodeNeighbors pkg ]
-mapConfiguredPackage :: (ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage)
- -> ElaboratedPlanPackage
- -> ElaboratedPlanPackage
+mapConfiguredPackage :: (srcpkg -> srcpkg')
+ -> InstallPlan.GenericPlanPackage ipkg srcpkg
+ -> InstallPlan.GenericPlanPackage ipkg srcpkg'
mapConfiguredPackage f (InstallPlan.Configured pkg) =
InstallPlan.Configured (f pkg)
-mapConfiguredPackage _ pkg = pkg
+mapConfiguredPackage _ (InstallPlan.PreExisting pkg) =
+ InstallPlan.PreExisting pkg
componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza
componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas
@@ -1630,39 +1806,6 @@ componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas
componentOptionalStanza _ = Nothing
-dependencyClosure :: (pkg -> InstalledPackageId)
- -> (pkg -> [InstalledPackageId])
- -> [pkg]
- -> [InstalledPackageId]
- -> [pkg]
-dependencyClosure pkgid deps allpkgs =
- map vertexToPkg
- . concatMap Tree.flatten
- . OldGraph.dfs graph
- . map pkgidToVertex
- where
- (graph, vertexToPkg, pkgidToVertex) = dependencyGraph pkgid deps allpkgs
-
--- TODO: Convert this to use Distribution.Compat.Graph, via a newtype
--- which explicitly carries the accessors.
-dependencyGraph :: (pkg -> InstalledPackageId)
- -> (pkg -> [InstalledPackageId])
- -> [pkg]
- -> (OldGraph.Graph,
- OldGraph.Vertex -> pkg,
- InstalledPackageId -> OldGraph.Vertex)
-dependencyGraph pkgid deps pkgs =
- (graph, vertexToPkg', pkgidToVertex')
- where
- (graph, vertexToPkg, pkgidToVertex) =
- OldGraph.graphFromEdges [ ( pkg, pkgid pkg, deps pkg )
- | pkg <- pkgs ]
- vertexToPkg' = (\(pkg,_,_) -> pkg)
- . vertexToPkg
- pkgidToVertex' = fromMaybe (error "dependencyGraph: lookup failure")
- . pkgidToVertex
-
-
---------------------------
-- Setup.hs script policy
--
@@ -1858,7 +2001,9 @@ setupHsScriptOptions :: ElaboratedReadyPackage
-> Bool
-> Lock
-> SetupScriptOptions
-setupHsScriptOptions (ReadyPackage ElaboratedConfiguredPackage{..})
+-- TODO: Fix this so custom is a separate component. Custom can ALWAYS
+-- be a separate component!!!
+setupHsScriptOptions (ReadyPackage (getElaboratedPackage -> ElaboratedPackage{..}))
ElaboratedSharedConfig{..} srcdir builddir
isParallelBuild cacheLock =
SetupScriptOptions {
@@ -1928,20 +2073,25 @@ setupHsConfigureFlags :: ElaboratedReadyPackage
-> Verbosity
-> FilePath
-> Cabal.ConfigFlags
-setupHsConfigureFlags (ReadyPackage
- pkg@ElaboratedConfiguredPackage{..})
+setupHsConfigureFlags (ReadyPackage pkg_or_comp)
sharedConfig@ElaboratedSharedConfig{..}
verbosity builddir =
- sanityCheckElaboratedConfiguredPackage sharedConfig pkg
+ sanityCheckElaboratedPackage sharedConfig pkg
(Cabal.ConfigFlags {..})
where
- configArgs = []
+ pkg@ElaboratedPackage{..} = getElaboratedPackage pkg_or_comp
+
+ configArgs = mempty -- unused, passed via args
configDistPref = toFlag builddir
configCabalFilePath = mempty
configVerbosity = toFlag verbosity
- configIPID = toFlag (display (installedUnitId pkg))
- configCID = mempty
+ configIPID = case pkg_or_comp of
+ ElabPackage _ -> toFlag (display (installedUnitId pkg))
+ ElabComponent _ -> mempty
+ configCID = case pkg_or_comp of
+ ElabPackage _ -> mempty
+ ElabComponent comp -> toFlag (unitIdComponentId (elabComponentId comp))
configProgramPaths = Map.toList pkgProgramPaths
configProgramArgs = Map.toList pkgProgramArgs
@@ -1982,13 +2132,20 @@ setupHsConfigureFlags (ReadyPackage
configProgPrefix = maybe mempty toFlag pkgProgPrefix
configProgSuffix = maybe mempty toFlag pkgProgSuffix
+ -- TODO: do this per-component
configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate)
pkgInstallDirs
-- we only use configDependencies, unless we're talking to an old Cabal
-- in which case we use configConstraints
+ -- NB: This does NOT use nodeNeighbors, which includes executable
+ -- dependencies which should NOT be fed in here
configDependencies = [ (packageName srcid, uid)
- | ConfiguredId srcid uid <- CD.nonSetupDeps pkgDependencies ]
+ | ConfiguredId srcid uid <-
+ case pkg_or_comp of
+ ElabPackage _ -> CD.nonSetupDeps pkgDependencies
+ ElabComponent comp -> elabComponentDependencies comp ]
+ -- TODO: don't need to provide these when pkgComponent is Just
configConstraints = [ thisPackageVersion srcid
| ConfiguredId srcid _uid <- CD.nonSetupDeps pkgDependencies ]
@@ -1996,8 +2153,12 @@ setupHsConfigureFlags (ReadyPackage
-- TODO: [required eventually] have to do this differently for older Cabal versions
configPackageDBs = Nothing : map Just pkgBuildPackageDBStack
- configTests = toFlag (TestStanzas `Set.member` pkgStanzasEnabled)
- configBenchmarks = toFlag (BenchStanzas `Set.member` pkgStanzasEnabled)
+ configTests = case pkg_or_comp of
+ ElabPackage _ -> toFlag (TestStanzas `Set.member` pkgStanzasEnabled)
+ ElabComponent _ -> mempty
+ configBenchmarks = case pkg_or_comp of
+ ElabPackage _ -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled)
+ ElabComponent _ -> mempty
configExactConfiguration = toFlag True
configFlagError = mempty --TODO: [research required] appears not to be implemented
@@ -2007,12 +2168,22 @@ setupHsConfigureFlags (ReadyPackage
configPrograms_ = mempty -- never use, shouldn't exist
+setupHsConfigureArgs :: ElaboratedConfiguredPackage
+ -> [String]
+setupHsConfigureArgs (ElabPackage _pkg) = []
+setupHsConfigureArgs (ElabComponent comp) =
+ [showComponentTarget pkg (ComponentTarget cname WholeComponent)]
+ where
+ pkg = elabComponentPackage comp
+ cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup")
+ (elabComponentName comp)
+
setupHsBuildFlags :: ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
-> FilePath
-> Cabal.BuildFlags
-setupHsBuildFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =
+setupHsBuildFlags _ _ verbosity builddir =
Cabal.BuildFlags {
buildProgramPaths = mempty, --unused, set at configure time
buildProgramArgs = mempty, --unused, set at configure time
@@ -2025,11 +2196,11 @@ setupHsBuildFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =
setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String]
-setupHsBuildArgs pkg =
- map (showComponentTarget pkg) (pkgBuildTargets pkg)
+setupHsBuildArgs (ElabPackage pkg) = map (showComponentTarget pkg) (pkgBuildTargets pkg)
+setupHsBuildArgs (ElabComponent _comp) = []
-showComponentTarget :: ElaboratedConfiguredPackage -> ComponentTarget -> String
+showComponentTarget :: ElaboratedPackage -> ComponentTarget -> String
showComponentTarget pkg =
showBuildTarget . toBuildTarget
where
@@ -2052,7 +2223,7 @@ setupHsReplFlags :: ElaboratedConfiguredPackage
-> Verbosity
-> FilePath
-> Cabal.ReplFlags
-setupHsReplFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =
+setupHsReplFlags _ _ verbosity builddir =
Cabal.ReplFlags {
replProgramPaths = mempty, --unused, set at configure time
replProgramArgs = mempty, --unused, set at configure time
@@ -2063,9 +2234,11 @@ setupHsReplFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =
setupHsReplArgs :: ElaboratedConfiguredPackage -> [String]
-setupHsReplArgs pkg =
+setupHsReplArgs (ElabPackage pkg) =
maybe [] (\t -> [showComponentTarget pkg t]) (pkgReplTarget pkg)
--TODO: should be able to give multiple modules in one component
+setupHsReplArgs (ElabComponent _comp) =
+ error "setupHsReplArgs: didn't implement me yet"
setupHsCopyFlags :: ElaboratedConfiguredPackage
@@ -2091,13 +2264,13 @@ setupHsRegisterFlags :: ElaboratedConfiguredPackage
-> FilePath
-> FilePath
-> Cabal.RegisterFlags
-setupHsRegisterFlags ElaboratedConfiguredPackage {pkgBuildStyle} _
+setupHsRegisterFlags pkg_or_comp _
verbosity builddir pkgConfFile =
Cabal.RegisterFlags {
regPackageDB = mempty, -- misfeature
regGenScript = mempty, -- never use
regGenPkgConf = toFlag (Just pkgConfFile),
- regInPlace = case pkgBuildStyle of
+ regInPlace = case pkgBuildStyle (getElaboratedPackage pkg_or_comp) of
BuildInplaceOnly -> toFlag True
_ -> toFlag False,
regPrintId = mempty, -- never use
@@ -2113,7 +2286,9 @@ setupHsHaddockFlags :: ElaboratedConfiguredPackage
-> Verbosity
-> FilePath
-> Cabal.HaddockFlags
-setupHsHaddockFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =
+-- TODO: reconsider whether or not Executables/TestSuites/...
+-- needed for component
+setupHsHaddockFlags (getElaboratedPackage -> ElaboratedPackage{..}) _ verbosity builddir =
Cabal.HaddockFlags {
haddockProgramPaths = mempty, --unused, set at configure time
haddockProgramArgs = mempty, --unused, set at configure time
@@ -2192,17 +2367,20 @@ packageHashInputs :: ElaboratedSharedConfig
-> PackageHashInputs
packageHashInputs
pkgshared
- pkg@ElaboratedConfiguredPackage{
+ (ElabPackage pkg@ElaboratedPackage{
pkgSourceId,
pkgSourceHash = Just srchash,
- pkgDependencies
- } =
+ pkgDependencies,
+ pkgExeDependencies
+ }) =
PackageHashInputs {
pkgHashPkgId = pkgSourceId,
+ pkgHashComponent = Nothing,
pkgHashSourceHash = srchash,
- pkgHashDirectDeps = Set.fromList
- [ installedPackageId dep
- | dep <- CD.select relevantDeps pkgDependencies ],
+ pkgHashDirectDeps = Set.fromList $
+ [ installedPackageId dep
+ | dep <- CD.select relevantDeps pkgDependencies ] ++
+ CD.select relevantDeps pkgExeDependencies,
pkgHashOtherConfig = packageHashConfigInputs pkgshared pkg
}
where
@@ -2217,16 +2395,29 @@ packageHashInputs
relevantDeps (CD.ComponentTest _) = False
relevantDeps (CD.ComponentBench _) = False
+packageHashInputs
+ pkgshared
+ (ElabComponent comp@ElaboratedComponent {
+ elabComponentPackage = pkg@ElaboratedPackage{ pkgSourceHash = Just srchash }
+ }) =
+ PackageHashInputs {
+ pkgHashPkgId = packageId comp,
+ pkgHashComponent = Just (elabComponent comp),
+ pkgHashSourceHash = srchash,
+ pkgHashDirectDeps = Set.fromList (nodeNeighbors comp),
+ pkgHashOtherConfig = packageHashConfigInputs pkgshared pkg
+ }
+
packageHashInputs _ pkg =
error $ "packageHashInputs: only for packages with source hashes. "
++ display (packageId pkg)
packageHashConfigInputs :: ElaboratedSharedConfig
- -> ElaboratedConfiguredPackage
+ -> ElaboratedPackage
-> PackageHashConfigInputs
packageHashConfigInputs
ElaboratedSharedConfig{..}
- ElaboratedConfiguredPackage{..} =
+ ElaboratedPackage{..} =
PackageHashConfigInputs {
pkgHashCompilerId = compilerId pkgConfigCompiler,
diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs
index afcefde732..76b60ffe75 100644
--- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs
+++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Types used while planning how to build everything in a project.
--
@@ -10,6 +12,17 @@ module Distribution.Client.ProjectPlanning.Types (
-- * Elaborated install plan types
ElaboratedInstallPlan,
ElaboratedConfiguredPackage(..),
+
+ getElaboratedPackage,
+ elabInstallDirs,
+ elabDistDirParams,
+ elabRequiresRegistration,
+ elabBuildTargets,
+ elabReplTarget,
+ elabBuildHaddocks,
+
+ ElaboratedComponent(..),
+ ElaboratedPackage(..),
ElaboratedPlanPackage,
ElaboratedSharedConfig(..),
ElaboratedReadyPackage,
@@ -32,7 +45,9 @@ import Distribution.Client.InstallPlan
( GenericInstallPlan, GenericPlanPackage )
import Distribution.Client.SolverInstallPlan
( SolverInstallPlan )
+import Distribution.Client.DistDirLayout
+import Distribution.Types.ComponentEnabledSpec
import Distribution.Package
hiding (InstalledPackageId, installedPackageId)
import Distribution.System
@@ -46,9 +61,10 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.InstallDirs (PathTemplate)
import Distribution.Version
+import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import Distribution.Solver.Types.OptionalStanza
-import Distribution.Solver.Types.PackageFixedDeps
+import Distribution.Compat.Graph (IsNode(..))
import Data.Map (Map)
import Data.Set (Set)
@@ -91,16 +107,151 @@ data ElaboratedSharedConfig
instance Binary ElaboratedSharedConfig
+-- TODO: This is a misnomer, but I didn't want to rename things
+-- willy-nilly yet
data ElaboratedConfiguredPackage
- = ElaboratedConfiguredPackage {
+ = ElabPackage ElaboratedPackage
+ | ElabComponent ElaboratedComponent
+ deriving (Eq, Show, Generic)
+
+instance IsNode ElaboratedConfiguredPackage where
+ type Key ElaboratedConfiguredPackage = UnitId
+ nodeKey (ElabPackage pkg) = nodeKey pkg
+ nodeKey (ElabComponent comp) = nodeKey comp
+ nodeNeighbors (ElabPackage pkg) = nodeNeighbors pkg
+ nodeNeighbors (ElabComponent comp) = nodeNeighbors comp
+
+elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams
+elabDistDirParams shared (ElabPackage pkg) = DistDirParams {
+ distParamUnitId = pkgInstalledId pkg,
+ distParamPackageId = pkgSourceId pkg,
+ distParamComponentName = Nothing,
+ distParamCompilerId = compilerId (pkgConfigCompiler shared),
+ distParamPlatform = pkgConfigPlatform shared
+ }
+elabDistDirParams shared (ElabComponent comp) = DistDirParams {
+ distParamUnitId = elabComponentId comp,
+ distParamPackageId = packageId comp, -- NB: NOT the munged ID
+ distParamComponentName = elabComponentName comp, -- TODO: Ick. Change type.
+ distParamCompilerId = compilerId (pkgConfigCompiler shared),
+ distParamPlatform = pkgConfigPlatform shared
+ }
+
+-- TODO: give each component a separate install dir prefix
+elabInstallDirs :: ElaboratedConfiguredPackage -> InstallDirs.InstallDirs FilePath
+elabInstallDirs = pkgInstallDirs . getElaboratedPackage
+
+elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool
+elabRequiresRegistration (ElabPackage pkg) = pkgRequiresRegistration pkg
+elabRequiresRegistration (ElabComponent comp)
+ = case elabComponent comp of
+ CD.ComponentLib -> True
+ CD.ComponentSubLib _ -> True
+ _ -> False
+
+elabBuildTargets :: ElaboratedConfiguredPackage -> [ComponentTarget]
+elabBuildTargets (ElabPackage pkg) = pkgBuildTargets pkg
+elabBuildTargets (ElabComponent comp)
+ | Just cname <- elabComponentName comp
+ = map (ComponentTarget cname) $ elabComponentBuildTargets comp
+ | otherwise = []
+
+elabReplTarget :: ElaboratedConfiguredPackage -> Maybe ComponentTarget
+elabReplTarget (ElabPackage pkg) = pkgReplTarget pkg
+elabReplTarget (ElabComponent comp)
+ | Just cname <- elabComponentName comp
+ = fmap (ComponentTarget cname) $ elabComponentReplTarget comp
+ | otherwise = Nothing
+
+elabBuildHaddocks :: ElaboratedConfiguredPackage -> Bool
+elabBuildHaddocks (ElabPackage pkg) = pkgBuildHaddocks pkg
+elabBuildHaddocks (ElabComponent comp) = elabComponentBuildHaddocks comp
+
+getElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage
+getElaboratedPackage (ElabPackage pkg) = pkg
+getElaboratedPackage (ElabComponent comp) = elabComponentPackage comp
+
+instance Binary ElaboratedConfiguredPackage
+
+instance Package ElaboratedConfiguredPackage where
+ packageId (ElabPackage pkg) = packageId pkg
+ packageId (ElabComponent comp) = packageId comp
+
+instance HasUnitId ElaboratedConfiguredPackage where
+ installedUnitId (ElabPackage pkg) = installedUnitId pkg
+ installedUnitId (ElabComponent comp) = installedUnitId comp
+
+instance HasConfiguredId ElaboratedConfiguredPackage where
+ configuredId (ElabPackage pkg) = configuredId pkg
+ configuredId (ElabComponent comp) = configuredId comp
+
+-- | Some extra metadata associated with an
+-- 'ElaboratedConfiguredPackage' which indicates that the "package"
+-- in question is actually a single component to be built. Arguably
+-- it would be clearer if there were an ADT which branched into
+-- package work items and component work items, but I've structured
+-- it this way to minimize change to the existing code (which I
+-- don't feel qualified to rewrite.)
+data ElaboratedComponent
+ = ElaboratedComponent {
+ -- | The name of the component to be built
+ elabComponent :: CD.Component,
+ -- | The name of the component to be built. Nothing if
+ -- it's a setup dep.
+ elabComponentName :: Maybe ComponentName,
+ -- | The ID of the component to be built
+ elabComponentId :: UnitId,
+ -- | Dependencies of this component
+ elabComponentDependencies :: [ConfiguredId],
+ -- | The order-only dependencies of this component; e.g.,
+ -- if you depend on an executable it goes here.
+ elabComponentExeDependencies :: [UnitId],
+ -- | The 'ElaboratedPackage' this component came from
+ elabComponentPackage :: ElaboratedPackage,
+ -- | What in this component should we build (TRANSIENT, see 'pkgBuildTargets')
+ elabComponentBuildTargets :: [SubComponentTarget],
+ -- | Should we REPL this component (TRANSIENT, see 'pkgReplTarget')
+ elabComponentReplTarget :: Maybe SubComponentTarget,
+ -- | Should we Haddock this component (TRANSIENT, see 'pkgBuildHaddocks')
+ elabComponentBuildHaddocks :: Bool
+ -- NB: Careful, if you add elabComponentInstallDirs, need
+ -- to adjust 'packageHashInputs'!!!
+ }
+ deriving (Eq, Show, Generic)
+
+instance Binary ElaboratedComponent
+
+instance Package ElaboratedComponent where
+ -- NB: DON'T return the munged ID by default.
+ -- The 'Package' type class is about the source package
+ -- name that the component belongs to; 'projAllPkgs'
+ -- in "Distribution.Client.ProjectOrchestration" depends
+ -- on this.
+ packageId = packageId . elabComponentPackage
+
+instance HasConfiguredId ElaboratedComponent where
+ configuredId comp = ConfiguredId (packageId comp) (installedUnitId comp)
+
+instance HasUnitId ElaboratedComponent where
+ installedUnitId = elabComponentId
+
+instance IsNode ElaboratedComponent where
+ type Key ElaboratedComponent = UnitId
+ nodeKey = elabComponentId
+ nodeNeighbors comp =
+ map installedUnitId (elabComponentDependencies comp)
+ ++ elabComponentExeDependencies comp
+
+data ElaboratedPackage
+ = ElaboratedPackage {
pkgInstalledId :: InstalledPackageId,
pkgSourceId :: PackageId,
- -- | TODO: [code cleanup] we don't need this, just a few bits from it:
- -- build type, spec version
pkgDescription :: Cabal.PackageDescription,
+ pkgInternalPackages :: Map PackageName ComponentName,
+
-- | A total flag assignment for the package
pkgFlagAssignment :: Cabal.FlagAssignment,
@@ -111,6 +262,13 @@ data ElaboratedConfiguredPackage
--
pkgDependencies :: ComponentDeps [ConfiguredId],
+ -- | The executable dependencies, which we don't pass as @--dependency@ flags;
+ -- these just need to be added to the path.
+ pkgExeDependencies :: ComponentDeps [UnitId],
+
+ -- | Another way of phrasing 'pkgStanzasAvailable'.
+ pkgEnabled :: ComponentEnabledSpec,
+
-- | Which optional stanzas (ie testsuites, benchmarks) can be built.
-- This means the solver produced a plan that has them available.
-- This doesn't necessary mean we build them by default.
@@ -226,16 +384,22 @@ data ElaboratedConfiguredPackage
}
deriving (Eq, Show, Generic)
-instance Binary ElaboratedConfiguredPackage
+instance Binary ElaboratedPackage
-instance Package ElaboratedConfiguredPackage where
+instance Package ElaboratedPackage where
packageId = pkgSourceId
-instance HasUnitId ElaboratedConfiguredPackage where
+instance HasUnitId ElaboratedPackage where
installedUnitId = pkgInstalledId
-instance PackageFixedDeps ElaboratedConfiguredPackage where
- depends = fmap (map installedPackageId) . pkgDependencies
+instance HasConfiguredId ElaboratedPackage where
+ configuredId pkg = ConfiguredId (pkgSourceId pkg) (pkgInstalledId pkg)
+
+instance IsNode ElaboratedPackage where
+ type Key ElaboratedPackage = UnitId
+ nodeKey = pkgInstalledId
+ nodeNeighbors pkg = map installedUnitId (CD.flatDeps (pkgDependencies pkg))
+ ++ CD.flatDeps (pkgExeDependencies pkg)
-- | This is used in the install plan to indicate how the package will be
-- built.
diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs
index 1b3a08890a..990e6f53f2 100644
--- a/cabal-install/Distribution/Client/Types.hs
+++ b/cabal-install/Distribution/Client/Types.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -21,7 +22,7 @@ module Distribution.Client.Types where
import Distribution.Package
( PackageName, PackageId, Package(..)
- , UnitId(..), HasUnitId(..) )
+ , UnitId(..), HasUnitId(..), PackageInstalled(..) )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.PackageDescription
@@ -31,11 +32,13 @@ import Distribution.Version
import Distribution.Solver.Types.PackageIndex
( PackageIndex )
+import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ComponentDeps
( ComponentDeps )
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageFixedDeps
import Distribution.Solver.Types.SourcePackage
+import Distribution.Compat.Graph (IsNode(..))
import Data.Map (Map)
import Network.URI (URI(..), URIAuth(..), nullURI)
@@ -98,8 +101,23 @@ data ConfiguredPackage loc = ConfiguredPackage {
}
deriving (Eq, Show, Generic)
+-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'.
+-- This type class is mostly used to conveniently finesse between
+-- 'ElaboratedPackage' and 'ElaboratedComponent'.
+--
+instance HasConfiguredId (ConfiguredPackage loc) where
+ configuredId pkg = ConfiguredId (packageId pkg) (confPkgId pkg)
+
+instance IsNode (ConfiguredPackage loc) where
+ type Key (ConfiguredPackage loc) = UnitId
+ nodeKey = confPkgId
+ -- TODO: if we update ConfiguredPackage to support order-only
+ -- dependencies, need to include those here
+ nodeNeighbors = map confInstId . CD.flatDeps . confPkgDeps
+
instance (Binary loc) => Binary (ConfiguredPackage loc)
+
-- | A ConfiguredId is a package ID for a configured package.
--
-- Once we configure a source package we know it's UnitId. It is still
@@ -115,7 +133,7 @@ data ConfiguredId = ConfiguredId {
confSrcId :: PackageId
, confInstId :: UnitId
}
- deriving (Eq, Generic)
+ deriving (Eq, Ord, Generic)
instance Binary ConfiguredId
@@ -131,16 +149,28 @@ instance HasUnitId ConfiguredId where
instance Package (ConfiguredPackage loc) where
packageId cpkg = packageId (confPkgSource cpkg)
-instance PackageFixedDeps (ConfiguredPackage loc) where
- depends cpkg = fmap (map installedUnitId) (confPkgDeps cpkg)
+instance PackageInstalled (ConfiguredPackage loc) where
+ installedDepends = CD.flatDeps . fmap (map installedUnitId) . confPkgDeps
instance HasUnitId (ConfiguredPackage loc) where
installedUnitId = confPkgId
+class HasConfiguredId a where
+ configuredId :: a -> ConfiguredId
+
+instance HasConfiguredId InstalledPackageInfo where
+ configuredId ipkg = ConfiguredId (packageId ipkg) (installedUnitId ipkg)
+
-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be
-- installed already, hence itself ready to be installed.
newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.
- deriving (Eq, Show, Generic, Package, PackageFixedDeps, HasUnitId, Binary)
+ deriving (Eq, Show, Generic, Package, PackageFixedDeps, HasUnitId, PackageInstalled, Binary)
+
+-- Can't newtype derive this
+instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where
+ type Key (GenericReadyPackage srcpkg) = Key srcpkg
+ nodeKey (ReadyPackage spkg) = nodeKey spkg
+ nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg
type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
@@ -287,6 +317,10 @@ data BuildFailure = PlanningFailed
instance Exception BuildFailure
+-- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only
+-- the public library's 'InstalledPackageInfo' is stored here, even if
+-- there were 'InstalledPackageInfo' from internal libraries. This
+-- 'InstalledPackageInfo' is not used anyway, so it makes no difference.
data BuildResult = BuildResult DocsResult TestsResult
(Maybe InstalledPackageInfo)
deriving (Show, Generic)
diff --git a/cabal-install/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install/Distribution/Solver/Types/ComponentDeps.hs
index 94781b8d0e..6c36cc6083 100644
--- a/cabal-install/Distribution/Solver/Types/ComponentDeps.hs
+++ b/cabal-install/Distribution/Solver/Types/ComponentDeps.hs
@@ -14,6 +14,7 @@
module Distribution.Solver.Types.ComponentDeps (
-- * Fine-grained package dependencies
Component(..)
+ , componentNameToComponent
, ComponentDep
, ComponentDeps -- opaque
-- ** Constructing ComponentDeps
@@ -41,6 +42,8 @@ import Distribution.Compat.Semigroup (Semigroup((<>)))
import GHC.Generics
import Data.Foldable (fold)
+import qualified Distribution.Types.ComponentName as CN
+
#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (Foldable(foldMap))
import Data.Monoid (Monoid(..))
@@ -90,6 +93,13 @@ instance Traversable ComponentDeps where
instance Binary a => Binary (ComponentDeps a)
+componentNameToComponent :: CN.ComponentName -> Component
+componentNameToComponent (CN.CLibName) = ComponentLib
+componentNameToComponent (CN.CSubLibName s) = ComponentSubLib s
+componentNameToComponent (CN.CExeName s) = ComponentExe s
+componentNameToComponent (CN.CTestName s) = ComponentTest s
+componentNameToComponent (CN.CBenchName s) = ComponentBench s
+
{-------------------------------------------------------------------------------
Construction
-------------------------------------------------------------------------------}
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 626d6c3f79..a157308386 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -88,6 +88,11 @@ Extra-Source-Files:
tests/IntegrationTests/new-build/T3460/sub-package-B/B.hs
tests/IntegrationTests/new-build/T3460/sub-package-B/Setup.hs
tests/IntegrationTests/new-build/T3460/sub-package-B/sub-package-B.cabal
+ tests/IntegrationTests/new-build/executable/Main.hs
+ tests/IntegrationTests/new-build/executable/Setup.hs
+ tests/IntegrationTests/new-build/executable/Test.hs
+ tests/IntegrationTests/new-build/executable/a.cabal
+ tests/IntegrationTests/new-build/executable/cabal.project
tests/IntegrationTests/new-build/monitor_cabal_files.sh
tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project
tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs
diff --git a/cabal-install/tests/IntegrationTests/internal-libs/new_build.sh b/cabal-install/tests/IntegrationTests/internal-libs/new_build.sh
index 959c79d079..18f708913a 100644
--- a/cabal-install/tests/IntegrationTests/internal-libs/new_build.sh
+++ b/cabal-install/tests/IntegrationTests/internal-libs/new_build.sh
@@ -1,4 +1,3 @@
. ./common.sh
-cabal new-build p || exit 0
-exit 1 # expect broken
+cabal new-build p
diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs b/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs
new file mode 100644
index 0000000000..b3549c2fe3
--- /dev/null
+++ b/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs
@@ -0,0 +1 @@
+main = return ()
diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs b/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs
new file mode 100644
index 0000000000..9a994af677
--- /dev/null
+++ b/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs b/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs
new file mode 100644
index 0000000000..b3549c2fe3
--- /dev/null
+++ b/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs
@@ -0,0 +1 @@
+main = return ()
diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal b/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal
new file mode 100644
index 0000000000..ed9fc2919a
--- /dev/null
+++ b/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal
@@ -0,0 +1,15 @@
+name: a
+version: 0.1
+cabal-version: >= 1.10
+build-type: Simple
+
+executable aexe
+ main-is: Main.hs
+ build-depends: base
+ default-language: Haskell2010
+
+test-suite atest
+ type: exitcode-stdio-1.0
+ main-is: Test.hs
+ build-depends: base
+ default-language: Haskell2010
diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project b/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project
new file mode 100644
index 0000000000..e6fdbadb43
--- /dev/null
+++ b/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project
@@ -0,0 +1 @@
+packages: .
diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs
index 3c7d2ae11e..6e2c3355af 100644
--- a/cabal-install/tests/IntegrationTests2.hs
+++ b/cabal-install/tests/IntegrationTests2.hs
@@ -237,12 +237,13 @@ planProject testdir cliConfig = do
let targets =
Map.fromList
[ (installedUnitId pkg, [BuildDefaultComponents])
- | InstallPlan.Configured pkg <- InstallPlan.toList elaboratedPlan
+ | InstallPlan.Configured pkg_or_comp <- InstallPlan.toList elaboratedPlan
+ , let pkg = getElaboratedPackage pkg_or_comp
, pkgBuildStyle pkg == BuildInplaceOnly ]
elaboratedPlan' = pruneInstallPlanToTargets targets elaboratedPlan
(elaboratedPlan'', pkgsBuildStatus) <-
- rebuildTargetsDryRun distDirLayout
+ rebuildTargetsDryRun verbosity distDirLayout elaboratedShared
elaboratedPlan'
let buildSettings = resolveBuildTimeSettings
@@ -350,30 +351,30 @@ expectPackagePreExisting plan buildOutcomes pkgid = do
(_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult
expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId
- -> IO ElaboratedConfiguredPackage
+ -> IO ElaboratedPackage
expectPackageConfigured plan buildOutcomes pkgid = do
planpkg <- expectPlanPackage plan pkgid
case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of
(InstallPlan.Configured pkg, Nothing)
- -> return pkg
+ -> return (getElaboratedPackage pkg)
(_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult
expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId
- -> IO (ElaboratedConfiguredPackage, BuildResult)
+ -> IO (ElaboratedPackage, BuildResult)
expectPackageInstalled plan buildOutcomes pkgid = do
planpkg <- expectPlanPackage plan pkgid
case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of
(InstallPlan.Configured pkg, Just (Right result))
- -> return (pkg, result)
+ -> return (getElaboratedPackage pkg, result)
(_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult
expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId
- -> IO (ElaboratedConfiguredPackage, BuildFailure)
+ -> IO (ElaboratedPackage, BuildFailure)
expectPackageFailed plan buildOutcomes pkgid = do
planpkg <- expectPlanPackage plan pkgid
case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of
(InstallPlan.Configured pkg, Just (Left failure))
- -> return (pkg, failure)
+ -> return (getElaboratedPackage pkg, failure)
(_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult
unexpectedBuildResult :: String -> ElaboratedPlanPackage
diff --git a/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal b/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal
index a9dced8d3a..f0bf220bef 100644
--- a/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal
+++ b/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal
@@ -1,3 +1,9 @@
name: a
version: 1
build-type: Simple
+-- This used to be a blank package with no components,
+-- but I refactored new-build so that if a package has
+-- no buildable components, we skip configuring it.
+-- So put in a (failing) component so that we try to
+-- configure.
+executable a
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
index f4fbf0fbeb..2d06a8cdb2 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
@@ -1,10 +1,14 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoMonoLocalBinds #-}
+{-# LANGUAGE ConstraintKinds #-}
module UnitTests.Distribution.Client.InstallPlan (tests) where
import Distribution.Package
import Distribution.Version
import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan (GenericInstallPlan)
+import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit)
import qualified Distribution.Compat.Graph as Graph
+import Distribution.Compat.Graph (IsNode(..))
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.PackageFixedDeps
import Distribution.Solver.Types.ComponentDeps as CD
@@ -146,6 +150,12 @@ instance Show TestInstallPlan where
data TestPkg = TestPkg PackageId UnitId [UnitId]
deriving (Eq, Show)
+instance IsNode TestPkg where
+ type Key TestPkg = UnitId
+ nodeKey (TestPkg _ ipkgid _) = ipkgid
+ nodeNeighbors (TestPkg _ _ deps) = deps
+
+
instance Package TestPkg where
packageId (TestPkg pkgid _ _) = pkgid
@@ -155,6 +165,9 @@ instance HasUnitId TestPkg where
instance PackageFixedDeps TestPkg where
depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps
+instance PackageInstalled TestPkg where
+ installedDepends (TestPkg _ _ deps) = deps
+
instance Arbitrary TestInstallPlan where
arbitrary = arbitraryTestInstallPlan
@@ -191,8 +204,8 @@ arbitraryTestInstallPlan = do
-- It takes generators for installed and source packages and the chance that
-- each package is installed (for those packages with no prerequisites).
--
-arbitraryInstallPlan :: (HasUnitId ipkg, PackageFixedDeps ipkg,
- HasUnitId srcpkg, PackageFixedDeps srcpkg)
+arbitraryInstallPlan :: (IsUnit ipkg,
+ IsUnit srcpkg)
=> (Vertex -> [Vertex] -> Gen ipkg)
-> (Vertex -> [Vertex] -> Gen srcpkg)
-> Float
@@ -222,9 +235,7 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do
]
let index = Graph.fromList (map InstallPlan.PreExisting ipkgs
++ map InstallPlan.Configured srcpkgs)
- case InstallPlan.new (IndependentGoals False) index of
- Right plan -> return plan
- Left _ -> error "arbitraryInstallPlan: generated invalid plan"
+ return $ InstallPlan.new (IndependentGoals False) index
-- | Generate a random directed acyclic graph, based on the algorithm presented
--
GitLab