Commit 09528c2d authored by Edward Z. Yang's avatar Edward Z. Yang

Delete FakeMap.

Compute 'UnitId' when we compute a 'ConfiguredPackage';
consequently, we can eliminate 'FakeMap' (finally!)
There is one hack remaining, which is that 'SolverInstallPlan'
gins up fake unit IDs so that it can be keyed on UnitIds.
But this data structure exists only very briefly before
being converted into an 'InstallPlan' or 'ElaboratedInstallPlan'.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent cfb124f5
......@@ -132,7 +132,7 @@ fromPlanPackage :: Platform -> CompilerId
-> InstallPlan.PlanPackage
-> Maybe (BuildReport, Maybe Repo)
fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
InstallPlan.Installed (ReadyPackage (ConfiguredPackage srcPkg flags _ deps))
InstallPlan.Installed (ReadyPackage (ConfiguredPackage _ srcPkg flags _ deps))
_ result
-> Just $ ( BuildReport.new os arch comp
(packageId srcPkg) flags
......@@ -140,7 +140,7 @@ fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
(Right result)
, extractRepo srcPkg)
InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result
InstallPlan.Failed (ConfiguredPackage _ srcPkg flags _ deps) result
-> Just $ ( BuildReport.new os arch comp
(packageId srcPkg) flags
(map confSrcId (CD.nonSetupDeps deps))
......
......@@ -134,7 +134,7 @@ configure verbosity packageDBs repoCtxt comp platform conf
let installPlan = InstallPlan.configureInstallPlan installPlan0
in case InstallPlan.ready installPlan of
[pkg@(ReadyPackage
(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _)
(ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _)
_ _ _))] -> do
configurePackage verbosity
platform (compilerInfo comp)
......@@ -346,7 +346,7 @@ configurePackage :: Verbosity
-> [String]
-> IO ()
configurePackage verbosity platform comp scriptOptions configFlags
(ReadyPackage (ConfiguredPackage spkg flags stanzas deps))
(ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps))
extraArgs =
setupWrapper verbosity
......@@ -355,6 +355,7 @@ configurePackage verbosity platform comp scriptOptions configFlags
where
gpkg = packageDescription spkg
configureFlags = filterConfigureFlags configFlags {
configIPID = toFlag (display ipid),
configConfigurationsFlags = flags,
-- We generate the legacy constraints as well as the new style precise
-- deps. In the end only one set gets passed to Setup.hs configure,
......
......@@ -39,7 +39,7 @@ import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Package
( Package, packageId, packageName, packageVersion )
( Package, packageId, packageName, packageVersion, installedUnitId )
import Distribution.Simple.Compiler
( Compiler, compilerInfo, PackageDBStack )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
......@@ -214,14 +214,17 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
-- 2) not a dependency (directly or transitively) of the package we are
-- freezing. This is useful for removing previously installed packages
-- which are no longer required from the install plan.
--
-- Invariant: @pkgSpecifiers@ must refer to packages which are not
-- 'PreExisting' in the 'SolverInstallPlan'.
pruneInstallPlan :: SolverInstallPlan
-> [PackageSpecifier UnresolvedSourcePackage]
-> [SolverPlanPackage]
pruneInstallPlan installPlan pkgSpecifiers =
removeSelf pkgIds $
InstallPlan.dependencyClosure installPlan (map fakeUnitId pkgIds)
InstallPlan.dependencyClosure installPlan (map installedUnitId pkgIds)
where
pkgIds = [ packageId pkg
pkgIds = [ PlannedId (packageId pkg)
| SpecificSourcePackage pkg <- pkgSpecifiers ]
removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)
removeSelf _ = error $ "internal error: 'pruneInstallPlan' given "
......
......@@ -119,8 +119,6 @@ import Distribution.Simple.Program (ProgramConfiguration,
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.LocalBuildInfo (ComponentName(CLibName))
import qualified Distribution.Simple.Configure as Configure
import Distribution.Simple.Setup
( haddockCommand, HaddockFlags(..)
, buildCommand, BuildFlags(..), emptyBuildFlags
......@@ -1205,18 +1203,17 @@ executeInstallPlan verbosity _comp jobCtl useLogFile plan0 installPkg =
(pkgid, ipid, buildResult) <- collectJob jobCtl
printBuildResult pkgid ipid buildResult
let taskCount' = taskCount-1
plan' = updatePlan pkgid buildResult plan
plan' = updatePlan pkgid ipid buildResult plan
tryNewTasks taskCount' plan'
updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan
updatePlan :: PackageIdentifier -> InstalledPackageId
-> BuildResult -> InstallPlan
-> InstallPlan
updatePlan pkgid (Right buildSuccess@(BuildOk _ _ mipkg)) =
InstallPlan.completed (Source.fakeUnitId pkgid)
mipkg buildSuccess
updatePlan _pkgid ipid (Right buildSuccess@(BuildOk _ _ mipkg)) =
InstallPlan.completed ipid mipkg buildSuccess
updatePlan pkgid (Left buildFailure) =
InstallPlan.failed (Source.fakeUnitId pkgid)
buildFailure depsFailure
updatePlan pkgid ipid (Left buildFailure) =
InstallPlan.failed ipid buildFailure depsFailure
where
depsFailure = DependentFailed pkgid
-- So this first pkgid failed for whatever reason (buildFailure).
......@@ -1259,11 +1256,12 @@ installReadyPackage :: Platform -> CompilerInfo
-> a)
-> a
installReadyPackage platform cinfo configFlags
(ReadyPackage (ConfiguredPackage
(ReadyPackage (ConfiguredPackage ipid
(SourcePackage _ gpkg source pkgoverride)
flags stanzas deps))
installPkg =
installPkg configFlags {
configIPID = toFlag (display ipid),
configConfigurationsFlags = flags,
-- We generate the legacy constraints as well as the new style precise deps.
-- In the end only one set gets passed to Setup.hs configure, depending on
......@@ -1415,20 +1413,9 @@ installUnpackedPackage verbosity buildLimit installLock numJobs
++ " with the latest revision from the index."
writeFileAtomic descFilePath pkgtxt
-- Compute the IPID of the *library*
let flags (ReadyPackage cpkg) = confPkgFlags cpkg
pkg_name = pkgName (PackageDescription.package pkg)
cid = Configure.computeComponentId
Cabal.NoFlag -- This would let us override the computation
(PackageDescription.package pkg)
(CLibName (display pkg_name))
(map (\(SimpleUnitId cid0) -> cid0) (CD.libraryDeps (depends rpkg)))
(flags rpkg)
ipid = SimpleUnitId cid
-- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if
-- the setup script was compiled against an old version of the Cabal lib).
configFlags' <- addDefaultInstallDirs ipid configFlags
configFlags' <- addDefaultInstallDirs configFlags
-- Filter out flags not supported by the old versions of the Cabal lib.
let configureFlags :: Version -> ConfigFlags
configureFlags = filterConfigureFlags configFlags' {
......@@ -1436,7 +1423,7 @@ installUnpackedPackage verbosity buildLimit installLock numJobs
}
-- Path to the optional log file.
mLogPath <- maybeLogPath ipid
mLogPath <- maybeLogPath
logDirChange (maybe putStr appendFile mLogPath) workingDir $ do
-- Configure phase
......@@ -1487,6 +1474,7 @@ installUnpackedPackage verbosity buildLimit installLock numJobs
where
pkgid = packageId pkg
ipid = installedUnitId rpkg
buildCommand' = buildCommand defaultProgramConfiguration
buildFlags _ = emptyBuildFlags {
buildDistPref = configDistPref configFlags,
......@@ -1515,8 +1503,8 @@ installUnpackedPackage verbosity buildLimit installLock numJobs
verbosity' = maybe verbosity snd useLogFile
tempTemplate name = name ++ "-" ++ display pkgid
addDefaultInstallDirs :: UnitId -> ConfigFlags -> IO ConfigFlags
addDefaultInstallDirs ipid configFlags' = do
addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags
addDefaultInstallDirs configFlags' = do
defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False
return $ configFlags' {
configInstallDirs = fmap Cabal.Flag .
......@@ -1555,8 +1543,8 @@ installUnpackedPackage verbosity buildLimit installLock numJobs
die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"
++ show perror
maybeLogPath :: UnitId -> IO (Maybe FilePath)
maybeLogPath ipid =
maybeLogPath :: IO (Maybe FilePath)
maybeLogPath =
case useLogFile of
Nothing -> return Nothing
Just (mkLogFileName, _) -> do
......
......@@ -66,16 +66,17 @@ import Distribution.Client.Types
, PackageFixedDeps(..)
, ConfiguredPackage(..), ConfiguredId(..)
, UnresolvedPkgLoc, SolverPackage(..)
, GenericReadyPackage(..), fakeUnitId )
, GenericReadyPackage(..) )
import Distribution.Version
( Version )
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Simple.PackageIndex
( PackageIndex )
import qualified Distribution.Simple.Configure as Configure
import qualified Distribution.Simple.Setup as Cabal
import qualified Distribution.PackageDescription as PD
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Client.PlanIndex
( FakeMap )
import qualified Distribution.Client.PlanIndex as PlanIndex
import Distribution.Text
( display )
......@@ -200,7 +201,6 @@ instance (HasUnitId ipkg, HasUnitId srcpkg) =>
data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan {
planIndex :: !(PlanIndex ipkg srcpkg iresult ifailure),
planFakeMap :: !FakeMap,
planIndepGoals :: !Bool,
-- | Cached (lazily) graph
......@@ -253,11 +253,22 @@ configureInstallPlan solverPlan =
-> ConfiguredPackage UnresolvedPkgLoc
configureSolverPackage mapDep spkg =
ConfiguredPackage {
confPkgId = SimpleUnitId
$ Configure.computeComponentId
Cabal.NoFlag
(packageId spkg)
(PD.CLibName (display (pkgName (packageId spkg))))
-- TODO: this is a hack that won't work for Backpack.
(map ((\(SimpleUnitId cid0) -> cid0) . confInstId)
(CD.libraryDeps deps))
(solverPkgFlags spkg),
confPkgSource = solverPkgSource spkg,
confPkgFlags = solverPkgFlags spkg,
confPkgStanzas = solverPkgStanzas spkg,
confPkgDeps = fmap (map (configureSolverId mapDep)) (solverPkgDeps spkg)
confPkgDeps = deps
}
where
deps = fmap (map (configureSolverId mapDep)) (solverPkgDeps spkg)
configureSolverId mapDep sid =
ConfiguredId {
......@@ -277,8 +288,7 @@ invariant :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool
invariant plan =
valid (planFakeMap plan)
(planIndepGoals plan)
valid (planIndepGoals plan)
(planIndex plan)
-- | Smart constructor that deals with caching the 'Graph' representation.
......@@ -286,13 +296,11 @@ invariant plan =
mkInstallPlan :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> PlanIndex ipkg srcpkg iresult ifailure
-> FakeMap
-> Bool
-> GenericInstallPlan ipkg srcpkg iresult ifailure
mkInstallPlan index fakeMap indepGoals =
mkInstallPlan index indepGoals =
GenericInstallPlan {
planIndex = index,
planFakeMap = fakeMap,
planIndepGoals = indepGoals,
-- lazily cache the graph stuff:
......@@ -303,7 +311,7 @@ mkInstallPlan index fakeMap indepGoals =
}
where
(graph, vertexToPkgId, pkgIdToVertex) =
PlanIndex.dependencyGraph fakeMap index
PlanIndex.dependencyGraph index
noSuchPkgId = internalError "package is not in the graph"
internalError :: String -> a
......@@ -315,13 +323,12 @@ instance (HasUnitId ipkg, PackageFixedDeps ipkg,
=> Binary (GenericInstallPlan ipkg srcpkg iresult ifailure) where
put GenericInstallPlan {
planIndex = index,
planFakeMap = fakeMap,
planIndepGoals = indepGoals
} = put (index, fakeMap, indepGoals)
} = put (index, indepGoals)
get = do
(index, fakeMap, indepGoals) <- get
return $! mkInstallPlan index fakeMap indepGoals
(index, indepGoals) <- get
return $! mkInstallPlan index indepGoals
showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg)
=> PlanIndex ipkg srcpkg iresult ifailure -> String
......@@ -334,11 +341,7 @@ showPlanIndex index =
showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg)
=> GenericInstallPlan ipkg srcpkg iresult ifailure -> String
showInstallPlan plan =
showPlanIndex (planIndex plan) ++ "\n" ++
"fake map:\n " ++
intercalate "\n " (map showKV (Map.toList (planFakeMap plan)))
where showKV (k,v) = display k ++ " -> " ++ display v
showInstallPlan = showPlanIndex . planIndex
showPlanPackageTag :: GenericPlanPackage ipkg srcpkg iresult ifailure -> String
showPlanPackageTag (PreExisting _) = "PreExisting"
......@@ -356,17 +359,8 @@ new :: (HasUnitId ipkg, PackageFixedDeps ipkg,
-> Either [PlanProblem ipkg srcpkg iresult ifailure]
(GenericInstallPlan ipkg srcpkg iresult ifailure)
new indepGoals index =
-- NB: Need to pre-initialize the fake-map with pre-existing
-- packages
let isPreExisting (PreExisting _) = True
isPreExisting _ = False
fakeMap = Map.fromList
. map (\p -> (fakeUnitId (packageId p)
,installedUnitId p))
. filter isPreExisting
$ PackageIndex.allPackages index in
case problems fakeMap indepGoals index of
[] -> Right (mkInstallPlan index fakeMap indepGoals)
case problems indepGoals index of
[] -> Right (mkInstallPlan index indepGoals)
probs -> Left probs
toList :: GenericInstallPlan ipkg srcpkg iresult ifailure
......@@ -424,11 +418,7 @@ lookupReadyPackage plan pkg = do
isInstalledDep :: UnitId -> Maybe ipkg
isInstalledDep pkgid =
-- NB: Need to check if the ID has been updated in planFakeMap, in which
-- case we might be dealing with an old pointer
case PlanIndex.fakeLookupUnitId
(planFakeMap plan) (planIndex plan) pkgid
of
case PackageIndex.lookupUnitId (planIndex plan) pkgid of
Just (PreExisting ipkg) -> Just ipkg
Just (Configured _) -> Nothing
Just (Processing _) -> Nothing
......@@ -471,19 +461,11 @@ completed :: (HasUnitId ipkg, PackageFixedDeps ipkg,
completed pkgid mipkg buildResult plan = assert (invariant plan') plan'
where
plan' = plan {
-- NB: installation can change the IPID, so better
-- record it in the fake mapping...
planFakeMap = insert_fake_mapping mipkg
$ planFakeMap plan,
planIndex = PackageIndex.insert installed
. PackageIndex.deleteUnitId pkgid
$ planIndex plan
}
-- ...but be sure to use the *old* IPID for the lookup for the
-- preexisting record
installed = Installed (lookupProcessingPackage plan pkgid) mipkg buildResult
insert_fake_mapping (Just ipkg) = Map.insert pkgid (installedUnitId ipkg)
insert_fake_mapping _ = id
-- | Marks a package in the graph as having failed. It also marks all the
-- packages that depended on it as having failed.
......@@ -520,7 +502,7 @@ packagesThatDependOn plan pkgid = map (planPkgOf plan)
. tail
. Graph.reachable (planGraphRev plan)
. planVertexOf plan
$ Map.findWithDefault pkgid pkgid (planFakeMap plan)
$ pkgid
-- | Lookup a package that we expect to be in the processing state.
--
......@@ -528,8 +510,6 @@ lookupProcessingPackage :: GenericInstallPlan ipkg srcpkg iresult ifailure
-> UnitId
-> GenericReadyPackage srcpkg
lookupProcessingPackage plan pkgid =
-- NB: processing packages are guaranteed to not indirect through
-- planFakeMap
case PackageIndex.lookupUnitId (planIndex plan) pkgid of
Just (Processing pkg) -> pkg
_ -> internalError $ "not in processing state or no such pkg " ++
......@@ -558,11 +538,6 @@ preexisting :: (HasUnitId ipkg, PackageFixedDeps ipkg,
preexisting pkgid ipkg plan = assert (invariant plan') plan'
where
plan' = plan {
-- NB: installation can change the IPID, so better
-- record it in the fake mapping...
planFakeMap = Map.insert pkgid
(installedUnitId ipkg)
(planFakeMap plan),
planIndex = PackageIndex.insert (PreExisting ipkg)
-- ...but be sure to use the *old* IPID for the lookup for
-- the preexisting record
......@@ -609,16 +584,12 @@ mapPreservingGraph :: (HasUnitId ipkg,
-> GenericInstallPlan ipkg' srcpkg' iresult' ifailure'
mapPreservingGraph f plan =
mkInstallPlan (PackageIndex.fromList pkgs')
Map.empty -- empty fakeMap
(planIndepGoals plan)
where
-- The package mapping function may change the UnitId. So we
-- walk over the packages in dependency order keeping track of these
-- package id changes and use it to supply the correct set of package
-- dependencies as an extra input to the package mapping function.
--
-- Having fully remapped all the deps this also means we can use an empty
-- FakeMap for the resulting install plan.
(_, pkgs') = foldl' f' (Map.empty, []) (reverseTopologicalOrder plan)
......@@ -648,11 +619,11 @@ mapPreservingGraph f plan =
--
valid :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> FakeMap -> Bool
=> Bool
-> PlanIndex ipkg srcpkg iresult ifailure
-> Bool
valid fakeMap indepGoals index =
null $ problems fakeMap indepGoals index
valid indepGoals index =
null $ problems indepGoals index
data PlanProblem ipkg srcpkg iresult ifailure =
PackageMissingDeps (GenericPlanPackage ipkg srcpkg iresult ifailure)
......@@ -700,28 +671,28 @@ showPlanProblem (PackageStateInvalid pkg pkg') =
--
problems :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> FakeMap -> Bool
=> Bool
-> PlanIndex ipkg srcpkg iresult ifailure
-> [PlanProblem ipkg srcpkg iresult ifailure]
problems fakeMap indepGoals index =
problems indepGoals index =
[ PackageMissingDeps pkg
(catMaybes
(map
(fmap packageId . PlanIndex.fakeLookupUnitId fakeMap index)
(fmap packageId . PackageIndex.lookupUnitId index)
missingDeps))
| (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ]
| (pkg, missingDeps) <- PlanIndex.brokenPackages index ]
++ [ PackageCycle cycleGroup
| cycleGroup <- PlanIndex.dependencyCycles fakeMap index ]
| cycleGroup <- PlanIndex.dependencyCycles index ]
++ [ PackageInconsistency name inconsistencies
| (name, inconsistencies) <-
PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]
PlanIndex.dependencyInconsistencies indepGoals index ]
++ [ PackageStateInvalid pkg pkg'
| pkg <- PackageIndex.allPackages index
, Just pkg' <- map (PlanIndex.fakeLookupUnitId fakeMap index)
, Just pkg' <- map (PackageIndex.lookupUnitId index)
(CD.flatDeps (depends pkg))
, not (stateDependencyRelation pkg pkg') ]
......@@ -732,8 +703,8 @@ problems fakeMap indepGoals index =
--
acyclic :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap
=> PlanIndex ipkg srcpkg iresult ifailure -> Bool
acyclic = null . PlanIndex.dependencyCycles
-- | An installation plan is closed if for every package in the set, all of
-- its dependencies are also in the set. That is, the set is closed under the
......@@ -744,8 +715,8 @@ acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap
--
closed :: (PackageFixedDeps ipkg,
PackageFixedDeps srcpkg)
=> FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
closed fakeMap = null . PlanIndex.brokenPackages fakeMap
=> PlanIndex ipkg srcpkg iresult ifailure -> Bool
closed = null . PlanIndex.brokenPackages
-- | An installation plan is consistent if all dependencies that target a
-- single package name, target the same version.
......@@ -765,8 +736,8 @@ closed fakeMap = null . PlanIndex.brokenPackages fakeMap
--
consistent :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap False
=> PlanIndex ipkg srcpkg iresult ifailure -> Bool
consistent = null . PlanIndex.dependencyInconsistencies False
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
......
......@@ -40,14 +40,14 @@ symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
import Distribution.Client.Types
( SourcePackage(..)
, GenericReadyPackage(..), ReadyPackage, enableStanzas
, ConfiguredPackage(..) , fakeUnitId)
, ConfiguredPackage(..))
import Distribution.Client.Setup
( InstallFlags(installSymlinkBinDir) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Package
( PackageIdentifier, Package(packageId), UnitId(..) )
( PackageIdentifier, Package(packageId), UnitId(..), installedUnitId )
import Distribution.Compiler
( CompilerId(..) )
import qualified Distribution.PackageDescription as PackageDescription
......@@ -123,10 +123,10 @@ symlinkBinaries platform comp configFlags installFlags plan =
then return Nothing
else return (Just (pkgid, publicExeName,
privateBinDir </> privateExeName))
| (ReadyPackage _cpkg, pkg, exe) <- exes
| (rpkg, pkg, exe) <- exes
, let pkgid = packageId pkg
-- This is a bit dodgy; probably won't work for Backpack packages
ipid = fakeUnitId pkgid
ipid = installedUnitId rpkg
publicExeName = PackageDescription.exeName exe
privateExeName = prefix ++ publicExeName ++ suffix
prefix = substTemplate pkgid ipid prefixTemplate
......@@ -141,7 +141,7 @@ symlinkBinaries platform comp configFlags installFlags plan =
pkgDescription :: ReadyPackage -> PackageDescription
pkgDescription (ReadyPackage (ConfiguredPackage
(SourcePackage _ pkg _ _)
_ (SourcePackage _ pkg _ _)
flags stanzas _)) =
case finalizePackageDescription flags
(const True)
......
......@@ -5,12 +5,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Distribution.Client.PlanIndex (
-- * FakeMap and related operations
FakeMap
, fakeDepends
, fakeLookupUnitId
-- * Graph traversal functions
, brokenPackages
brokenPackages
, dependencyCycles
, dependencyGraph
, dependencyInconsistencies
......@@ -35,7 +31,6 @@ import Distribution.Package
import Distribution.Version
( Version )
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Client.Types
( PackageFixedDeps(..) )
......@@ -44,65 +39,19 @@ import Distribution.Simple.PackageIndex
import Distribution.Package
( HasUnitId(..), PackageId )
-- Note [FakeMap]
-----------------
-- We'd like to use the PackageIndex defined in this module for cabal-install's
-- InstallPlan. However, at the moment, this data structure is indexed by
-- UnitId, which we don't know until after we've compiled a package
-- (whereas InstallPlan needs to store not-compiled packages in the index.)
-- Eventually, an UnitId will be calculatable prior to actually building
-- the package, but at the moment, the "fake installed package ID map" is a
-- workaround to solve this problem while reusing PackageIndex. The basic idea
-- is that, since we don't know what an UnitId is beforehand, we just fake
-- up one based on the package ID (it only needs to be unique for the particular
-- install plan), and fill it out with the actual generated UnitId after
-- the package is successfully compiled.
--
-- However, there is a problem: in the index there may be references using the
-- old package ID, which are now dangling if we update the UnitId. We
-- could map over the entire index to update these pointers as well (a costly
-- operation), but instead, we've chosen to parametrize a variety of important
-- functions by a FakeMap, which records what a fake installed package ID was
-- actually resolved to post-compilation. If we do a lookup, we first check and
-- see if it's a fake ID in the FakeMap.
--
-- It's a bit grungy, but we expect this to only be temporary anyway. (Another
-- possible workaround would have been to *not* update the installed package ID,
-- but I decided this would be hard to understand.)
-- | Map from fake package keys to real ones. See Note [FakeMap]
type FakeMap = Map UnitId UnitId
-- | Variant of `depends` which accepts a `FakeMap`
--
-- Analogous to `fakeInstalledDepends`. See Note [FakeMap].
fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [UnitId]
fakeDepends fakeMap = fmap (map resolveFakeId) . depends
where
resolveFakeId :: UnitId -> UnitId
resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap
--- | Variant of 'lookupUnitId' which accepts a 'FakeMap'. See Note
--- [FakeMap].
fakeLookupUnitId :: FakeMap -> PackageIndex a -> UnitId
-> Maybe a
fakeLookupUnitId fakeMap index pkg =
lookupUnitId index (Map.findWithDefault pkg pkg fakeMap)
-- | All packages that have dependencies that are not in the index.
--
-- Returns such packages along with the dependencies that they're missing.
--
brokenPackages :: (PackageFixedDeps pkg)
=> FakeMap
-> PackageIndex pkg
=> PackageIndex pkg
-> [(pkg, [UnitId])]
brokenPackages fakeMap index =
brokenPackages index =
[ (pkg, missing)
| pkg <- allPackages index
, let missing =
[ pkg' | pkg' <- CD.flatDeps (depends pkg)
, isNothing (fakeLookupUnitId fakeMap index pkg') ]
, isNothing (lookupUnitId index pkg') ]
, not (null missing) ]
-- | Compute all roots of the install plan, and verify that the transitive
......@@ -113,17 +62,16 @@ brokenPackages fakeMap index =