Skip to content
GitLab
Commit 7b67f37b authored by Edward Z. Yang's avatar Edward Z. Yang Committed by GitHub
Browse files

Merge pull request #3863 from haskell/installplan-installed-state 

Installplan installed state
parents c12290f8 66ed37a2
Hide whitespace changes
Inline Side-by-side
cabal-install/Distribution/Client/InstallPlan.hs
View file @ 7b67f37b
......@@ -33,7 +33,7 @@ module Distribution.Client.InstallPlan (
fromSolverInstallPlan,
configureInstallPlan,
remove,
preexisting,
installed,
lookup,
directDeps,
revDirectDeps,
......@@ -159,6 +159,7 @@ import Prelude hiding (lookup)
data GenericPlanPackage ipkg srcpkg
= PreExisting ipkg
| Configured srcpkg
| Installed srcpkg
deriving (Eq, Show, Generic)
type IsUnit a = (IsNode a, Key a ~ UnitId)
......@@ -172,9 +173,11 @@ instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
=> IsNode (GenericPlanPackage ipkg srcpkg) where
type Key (GenericPlanPackage ipkg srcpkg) = UnitId
nodeKey (PreExisting ipkg) = nodeKey ipkg
nodeKey (Configured spkg) = nodeKey spkg
nodeKey (Configured spkg) = nodeKey spkg
nodeKey (Installed spkg) = nodeKey spkg
nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg
nodeNeighbors (Configured spkg) = nodeNeighbors spkg
nodeNeighbors (Configured spkg) = nodeNeighbors spkg
nodeNeighbors (Installed spkg) = nodeNeighbors spkg
instance (Binary ipkg, Binary srcpkg)
=> Binary (GenericPlanPackage ipkg srcpkg)
......@@ -186,17 +189,20 @@ instance (Package ipkg, Package srcpkg) =>
Package (GenericPlanPackage ipkg srcpkg) where
packageId (PreExisting ipkg) = packageId ipkg
packageId (Configured spkg) = packageId spkg
packageId (Installed spkg) = packageId spkg
instance (HasUnitId ipkg, HasUnitId srcpkg) =>
HasUnitId
(GenericPlanPackage ipkg srcpkg) where
installedUnitId (PreExisting ipkg) = installedUnitId ipkg
installedUnitId (Configured spkg) = installedUnitId spkg
installedUnitId (Installed spkg) = installedUnitId spkg
instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
HasConfiguredId (GenericPlanPackage ipkg srcpkg) where
configuredId (PreExisting ipkg) = configuredId ipkg
configuredId (Configured pkg) = configuredId pkg
configuredId (Configured spkg) = configuredId spkg
configuredId (Installed spkg) = configuredId spkg
data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
planIndex :: !(PlanIndex ipkg srcpkg),
......@@ -255,6 +261,7 @@ showInstallPlan = showPlanIndex . planIndex
showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag (PreExisting _) = "PreExisting"
showPlanPackageTag (Configured _) = "Configured"
showPlanPackageTag (Installed _) = "Installed"
-- | Build an installation plan from a valid set of resolved packages.
--
......@@ -283,25 +290,27 @@ remove shouldRemove plan =
newIndex = Graph.fromList $
filter (not . shouldRemove) (toList plan)
-- | Replace a ready package with a pre-existing one. The pre-existing one
-- must have exactly the same dependencies as the source one was configured
-- with.
--
preexisting :: (IsUnit ipkg,
IsUnit srcpkg)
=> UnitId
-> ipkg
-> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg
preexisting pkgid ipkg plan = plan'
-- | Change a number of packages in the 'Configured' state to the 'Installed'
-- state.
--
-- To preserve invariants, the package must have all of its dependencies
-- already installed too (that is 'PreExisting' or 'Installed').
--
installed :: (IsUnit ipkg, IsUnit srcpkg)
=> (srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg
installed shouldBeInstalled installPlan =
foldl' markInstalled installPlan
[ pkg
| Configured pkg <- reverseTopologicalOrder installPlan
, shouldBeInstalled pkg ]
where
plan' = plan {
planIndex = Graph.insert (PreExisting ipkg)
-- ...but be sure to use the *old* IPID for the lookup for
-- the preexisting record
. Graph.deleteKey pkgid
$ planIndex plan
}
markInstalled plan pkg =
assert (all isInstalled (directDeps plan (nodeKey pkg))) $
plan {
planIndex = Graph.insert (Installed pkg) (planIndex plan)
}
-- | Lookup a package in the plan.
--
......@@ -509,17 +518,18 @@ ready plan =
!processing =
Processing
(Set.fromList [ nodeKey pkg | pkg <- readyPackages ])
(Set.fromList [ nodeKey pkg | PreExisting pkg <- toList plan ])
(Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ])
Set.empty
readyPackages =
[ ReadyPackage pkg
| Configured pkg <- toList plan
, all isPreExisting (directDeps plan (nodeKey pkg))
, all isInstalled (directDeps plan (nodeKey pkg))
]
isPreExisting (PreExisting {}) = True
isPreExisting _ = False
isInstalled :: GenericPlanPackage a b -> Bool
isInstalled (PreExisting {}) = True
isInstalled (Installed {}) = True
isInstalled _ = False
-- | Given a package in the processing state, mark the package as completed
-- and return any packages that are newly in the processing state (ie ready to
......@@ -592,6 +602,7 @@ processingInvariant plan (Processing processingSet completedSet failedSet) =
&& and [ case Graph.lookup pkgid (planIndex plan) of
Just (Configured _) -> True
Just (PreExisting _) -> False
Just (Installed _) -> False
Nothing -> False
| pkgid <- Set.toList processingSet ++ Set.toList failedSet ]
where
......
cabal-install/Distribution/Client/ProjectBuilding.hs
View file @ 7b67f37b
......@@ -146,6 +146,10 @@ data BuildStatus =
-- need building.
BuildStatusPreExisting
-- | The package is in the 'InstallPlan.Installed' state, so does not
-- need building.
| BuildStatusInstalled
-- | The package has not been downloaded yet, so it will have to be
-- downloaded, unpacked and built.
| BuildStatusDownload
......@@ -166,6 +170,7 @@ data BuildStatus =
buildStatusToString :: BuildStatus -> String
buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting"
buildStatusToString BuildStatusInstalled = "BuildStatusInstalled"
buildStatusToString BuildStatusDownload = "BuildStatusDownload"
buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp
buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp
......@@ -229,6 +234,7 @@ data BuildReason =
--
buildStatusRequiresBuild :: BuildStatus -> Bool
buildStatusRequiresBuild BuildStatusPreExisting = False
buildStatusRequiresBuild BuildStatusInstalled = False
buildStatusRequiresBuild BuildStatusUpToDate {} = False
buildStatusRequiresBuild _ = True
......@@ -251,7 +257,7 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install
-- For 'BuildStatusUpToDate' packages, improve the plan by marking them as
-- 'InstallPlan.Installed'.
let installPlan' = improveInstallPlanWithUpToDatePackages
installPlan pkgsBuildStatus
pkgsBuildStatus installPlan
debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
return (installPlan', pkgsBuildStatus)
......@@ -262,6 +268,9 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install
dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
return BuildStatusPreExisting
dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =
return BuildStatusInstalled
dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
mloc <- checkFetched (elabPkgSourceLocation pkg)
case mloc of
......@@ -356,29 +365,18 @@ foldMInstallPlanDepOrder plan0 visit =
let results' = Map.insert (nodeKey pkg) result results
go results' pkgs
improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
-> BuildStatusMap
improveInstallPlanWithUpToDatePackages :: BuildStatusMap
-> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
replaceWithPrePreExisting installPlan
[ (installedUnitId pkg, mipkg)
| InstallPlan.Configured pkg
<- InstallPlan.reverseTopologicalOrder installPlan
, let uid = installedUnitId pkg
Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus
, BuildStatusUpToDate (BuildResult { buildResultLibInfo = mipkg })
<- [pkgBuildStatus]
]
-> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
InstallPlan.installed canPackageBeImproved
where
replaceWithPrePreExisting =
foldl' (\plan (uid, mipkg) ->
-- TODO: A grievous hack. Better to have a special type
-- of entry representing pre-existing executables.
let stub_ipkg = Installed.emptyInstalledPackageInfo {
Installed.installedUnitId = uid
}
ipkg = fromMaybe stub_ipkg mipkg
in InstallPlan.preexisting uid ipkg plan)
canPackageBeImproved pkg =
case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
Just BuildStatusUpToDate {} -> True
Just _ -> False
Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "
++ display (packageId pkg) ++ " not in status map"
-----------------------------
......@@ -745,6 +743,7 @@ rebuildTarget verbosity
-- TODO: perhaps re-nest the types to make these impossible
BuildStatusPreExisting {} -> unexpectedState
BuildStatusInstalled {} -> unexpectedState
BuildStatusUpToDate {} -> unexpectedState
where
unexpectedState = error "rebuildTarget: unexpected package status"
......
cabal-install/Distribution/Client/ProjectOrchestration.hs
View file @ 7b67f37b
......@@ -532,7 +532,8 @@ printPlan verbosity
partialConfigureFlags
showBuildStatus status = case status of
BuildStatusPreExisting -> "already installed"
BuildStatusPreExisting -> "existing package"
BuildStatusInstalled -> "already installed"
BuildStatusDownload {} -> "requires download & build"
BuildStatusUnpack {} -> "requires build"
BuildStatusRebuild _ rebuild -> case rebuild of
......
cabal-install/Distribution/Client/ProjectPlanOutput.hs
View file @ 7b67f37b
......@@ -2,8 +2,6 @@
DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
ScopedTypeVariables #-}
-- | An experimental new UI for cabal for working with multiple packages
-----------------------------------------------------------------------------
module Distribution.Client.ProjectPlanOutput (
writePlanExternalRepresentation,
) where
......@@ -19,6 +17,7 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
import Distribution.Package
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.PackageDescription as PD
import Distribution.Text
import Distribution.Simple.Utils
......@@ -29,6 +28,10 @@ import qualified Data.ByteString.Builder as BB
import System.FilePath
-----------------------------------------------------------------------------
-- Writing plan.json files
--
-- | Write out a representation of the elaborated install plan.
--
-- This is for the benefit of debugging and external tools like editors.
......@@ -53,27 +56,37 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
-- the parts of the elaboratedInstallPlan
J.object [ "cabal-version" J..= jdisplay Our.version
, "cabal-lib-version" J..= jdisplay cabalVersion
, "install-plan" J..= jsonIPlan
, "install-plan" J..= installPlanToJ elaboratedInstallPlan
]
where
jsonIPlan = map toJ (InstallPlan.toList elaboratedInstallPlan)
-- ipi :: InstalledPackageInfo
toJ (InstallPlan.PreExisting ipi) =
-- installed packages currently lack configuration information
-- such as their flag settings or non-lib components.
installPlanToJ :: ElaboratedInstallPlan -> [J.Value]
installPlanToJ = map planPackageToJ . InstallPlan.toList
planPackageToJ :: ElaboratedPlanPackage -> J.Value
planPackageToJ pkg =
case pkg of
InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi
InstallPlan.Configured elab -> elaboratedPackageToJ False elab
InstallPlan.Installed elab -> elaboratedPackageToJ True elab
installedPackageInfoToJ :: InstalledPackageInfo -> J.Value
installedPackageInfoToJ ipi =
-- Pre-existing packages lack configuration information such as their flag
-- settings or non-lib components. We only get pre-existing packages for
-- the global/core packages however, so this isn't generally a problem.
-- So these packages are never local to the project.
--
-- TODO: how to find out whether package is "local"?
J.object
[ "type" J..= J.String "pre-existing"
, "id" J..= jdisplay (installedUnitId ipi)
, "depends" J..= map jdisplay (installedDepends ipi)
]
-- pkg :: ElaboratedPackage
toJ (InstallPlan.Configured elab) =
elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value
elaboratedPackageToJ isInstalled elab =
J.object $
[ "type" J..= J.String "configured"
[ "type" J..= J.String (if isInstalled then "installed"
else "configured")
, "id" J..= (jdisplay . installedUnitId) elab
, "flags" J..= J.object [ fn J..= v
| (PD.FlagName fn,v) <-
......
cabal-install/Distribution/Client/ProjectPlanning.hs
View file @ 7b67f37b
......@@ -87,12 +87,10 @@ import Distribution.Solver.Types.SourcePackage
import Distribution.Package hiding
(InstalledPackageId, installedPackageId)
import Distribution.System
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Configuration as PD
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Compiler hiding (Flag)
import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate
import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate
......@@ -607,22 +605,23 @@ rebuildInstallPlan verbosity
liftIO $ debug verbosity "Improving the install plan..."
recreateDirectory verbosity True storeDirectory
storePkgIndex <- getPackageDBContents verbosity
compiler progdb platform
storePackageDb
storeExeIndex <- getExecutableDBContents storeDirectory
let improvedPlan = improveInstallPlanWithPreExistingPackages
storePkgIndex
storeExeIndex
liftIO $ createPackageDBIfMissing verbosity
compiler progdb
storePackageDb
storePkgIdSet <- getInstalledStorePackages storeDirectory
let improvedPlan = improveInstallPlanWithInstalledPackages
storePkgIdSet
elaboratedPlan
liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan)
-- TODO: [nice to have] having checked which packages from the store
-- we're using, it may be sensible to sanity check those packages
-- by loading up the compiler package db and checking everything
-- matches up as expected, e.g. no dangling deps, files deleted.
return improvedPlan
where
storeDirectory = cabalStoreDirectory (compilerId compiler)
storePackageDb = cabalStorePackageDB (compilerId compiler)
ElaboratedSharedConfig {
pkgConfigPlatform = platform,
pkgConfigCompiler = compiler,
pkgConfigCompilerProgs = progdb
} = elaboratedShared
......@@ -659,6 +658,8 @@ getInstalledPackages verbosity compiler progdb platform packagedbs = do
verbosity compiler
packagedbs progdb
{-
--TODO: [nice to have] use this but for sanity / consistency checking
getPackageDBContents :: Verbosity
-> Compiler -> ProgramDb -> Platform
-> PackageDB
......@@ -672,20 +673,21 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do
createPackageDBIfMissing verbosity compiler progdb packagedb
Cabal.getPackageDBContents verbosity compiler
packagedb progdb
-}
-- | Return the list of all already installed executables
getExecutableDBContents
:: FilePath -- store directory
-> Rebuild (Set ComponentId)
getExecutableDBContents storeDirectory = do
monitorFiles [monitorFileGlob (FilePathGlob (FilePathRoot storeDirectory) (GlobFile [WildCard]))]
paths <- liftIO $ getDirectoryContents storeDirectory
return (Set.fromList (map ComponentId (filter valid paths)))
-- | Return the 'UnitId's of all packages\/components already installed in the
-- store.
--
getInstalledStorePackages :: FilePath -- ^ store directory
-> Rebuild (Set UnitId)
getInstalledStorePackages storeDirectory = do
paths <- getDirectoryContentsMonitored storeDirectory
return $ Set.fromList [ SimpleUnitId (ComponentId path)
| path <- paths, valid path ]
where
valid "." = False
valid ".." = False
valid ('.':_) = False
valid "package.db" = False
valid _ = True
valid _ = True
getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
-> Rebuild SourcePackageDb
......@@ -731,6 +733,11 @@ getPkgConfigDb verbosity progdb = do
liftIO $ readPkgConfigDb verbosity progdb
getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]
getDirectoryContentsMonitored dir = do
monitorFiles [monitorDirectory dir]
liftIO $ getDirectoryContents dir
recreateDirectory :: Verbosity -> Bool -> FilePath -> Rebuild ()
recreateDirectory verbosity createParents dir = do
liftIO $ createDirectoryIfMissingVerbose verbosity createParents dir
......@@ -1235,6 +1242,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB
case elabPkgOrComp elab of
ElabPackage _ -> True
ElabComponent comp -> compSolverName comp == CD.ComponentLib
is_lib (InstallPlan.Installed _) = unexpectedState
elaborateExeSolverId :: (SolverId -> [ElaboratedPlanPackage])
-> SolverId -> [ConfiguredId]
......@@ -1247,6 +1255,7 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB
case compSolverName comp of
CD.ComponentExe _ -> True
_ -> False
is_exe (InstallPlan.Installed _) = unexpectedState
elaborateExePath :: (SolverId -> [ElaboratedPlanPackage])
-> SolverId -> [FilePath]
......@@ -1269,6 +1278,9 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB
Just (Just n) -> n
_ -> ""
else InstallDirs.bindir (elabInstallDirs elab)]
get_exe_path (InstallPlan.Installed _) = unexpectedState
unexpectedState = error "elaborateInstallPlan: unexpected Installed state"
elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage])
-> SolverPackage UnresolvedPkgLoc
......@@ -1994,6 +2006,8 @@ mapConfiguredPackage :: (srcpkg -> srcpkg')
-> InstallPlan.GenericPlanPackage ipkg srcpkg'
mapConfiguredPackage f (InstallPlan.Configured pkg) =
InstallPlan.Configured (f pkg)
mapConfiguredPackage f (InstallPlan.Installed pkg) =
InstallPlan.Installed (f pkg)
mapConfiguredPackage _ (InstallPlan.PreExisting pkg) =
InstallPlan.PreExisting pkg
......@@ -2703,20 +2717,17 @@ packageHashConfigInputs
-- | Given the 'InstalledPackageIndex' for a nix-style package store, and an
-- 'ElaboratedInstallPlan', replace configured source packages by pre-existing
-- installed packages whenever they exist.
-- 'ElaboratedInstallPlan', replace configured source packages by installed
-- packages from the store whenever they exist.
--
improveInstallPlanWithPreExistingPackages :: InstalledPackageIndex
-> Set ComponentId
-> ElaboratedInstallPlan
-> ElaboratedInstallPlan
improveInstallPlanWithPreExistingPackages installedPkgIndex installedExes installPlan =
replaceWithPreExisting installPlan
[ ipkg
| InstallPlan.Configured pkg
<- InstallPlan.reverseTopologicalOrder installPlan
, ipkg <- maybeToList (canPackageBeImproved pkg) ]
improveInstallPlanWithInstalledPackages :: Set UnitId
-> ElaboratedInstallPlan
-> ElaboratedInstallPlan
improveInstallPlanWithInstalledPackages installedPkgIdSet =
InstallPlan.installed canPackageBeImproved
where
canPackageBeImproved pkg =
installedUnitId pkg `Set.member` installedPkgIdSet
--TODO: sanity checks:
-- * the installed package must have the expected deps etc
-- * the installed package must not be broken, valid dep closure
......@@ -2724,18 +2735,3 @@ improveInstallPlanWithPreExistingPackages installedPkgIndex installedExes instal
--TODO: decide what to do if we encounter broken installed packages,
-- since overwriting is never safe.
canPackageBeImproved pkg =
case PackageIndex.lookupUnitId
installedPkgIndex (installedUnitId pkg) of
Just x -> Just x
Nothing | SimpleUnitId cid <- installedUnitId pkg
, cid `Set.member` installedExes
-- Same hack as replacewithPrePreExisting
-> Just (Installed.emptyInstalledPackageInfo {
Installed.installedUnitId = installedUnitId pkg
})
| otherwise -> Nothing
replaceWithPreExisting =
foldl' (\plan ipkg -> InstallPlan.preexisting
(installedUnitId ipkg) ipkg plan)
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment