Commit 5ba1542f authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #1592 from 23Skidoo/ready-package

Refactoring: change the return type of 'InstallPlan.ready'.
parents ef0973e5 2a75a448
......@@ -117,9 +117,10 @@ fromPlanPackage :: Platform -> CompilerId
-> Maybe (BuildReport, Repo)
fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {
InstallPlan.Installed pkg@(ReadyPackage (SourcePackage {
packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
-> Just $ (BuildReport.new os arch comp pkg (Right result), repo)
-> Just $ (BuildReport.new os arch comp
(readyPackageToConfiguredPackage pkg) (Right result), repo)
InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {
packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
......
......@@ -36,6 +36,7 @@ import Distribution.Simple.Setup
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Simple.Utils
( defaultPackageDesc )
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
( Package(..), packageName, Dependency(..), thisPackageVersion )
import Distribution.PackageDescription.Parse
......@@ -80,7 +81,7 @@ configure verbosity packageDBs repos comp platform conf
Left message -> die message
Right installPlan -> case InstallPlan.ready installPlan of
[(pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _), _)] ->
[pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->
configurePackage verbosity
(InstallPlan.planPlatform installPlan)
(InstallPlan.planCompiler installPlan)
......@@ -181,20 +182,22 @@ planLocalPackage verbosity comp platform configFlags configExFlags installedPkgI
-- | Call an installer for an 'SourcePackage' but override the configure
-- flags with the ones given by the 'ConfiguredPackage'. In particular the
-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly
-- flags with the ones given by the 'ReadyPackage'. In particular the
-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly
-- versioned package dependencies. So we ignore any previous partial flag
-- assignment or dependency constraints and use the new ones.
--
-- NB: when updating this function, don't forget to also update
-- 'installReadyPackage' in D.C.Install.
configurePackage :: Verbosity
-> Platform -> CompilerId
-> SetupScriptOptions
-> ConfigFlags
-> ConfiguredPackage
-> ReadyPackage
-> [String]
-> IO ()
configurePackage verbosity platform comp scriptOptions configFlags
(ConfiguredPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =
(ReadyPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =
setupWrapper verbosity
scriptOptions (Just pkg) configureCommand configureFlags extraArgs
......@@ -202,7 +205,14 @@ configurePackage verbosity platform comp scriptOptions configFlags
where
configureFlags = filterConfigureFlags configFlags {
configConfigurationsFlags = flags,
configConstraints = map thisPackageVersion deps,
-- 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 the Cabal version we are talking to.
configConstraints = [ thisPackageVersion (packageId deppkg)
| deppkg <- deps ],
configDependencies = [ (packageName (Installed.sourcePackageId deppkg),
Installed.installedPackageId deppkg)
| deppkg <- deps ],
configVerbosity = toFlag verbosity,
configBenchmarks = toFlag (BenchStanzas `elem` stanzas),
configTests = toFlag (TestStanzas `elem` stanzas)
......@@ -211,5 +221,5 @@ configurePackage verbosity platform comp scriptOptions configFlags
pkg = case finalizePackageDescription flags
(const True)
platform comp [] (enableStanzas stanzas gpkg) of
Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
Left _ -> error "finalizePackageDescription ReadyPackage failed"
Right (desc, _) -> desc
......@@ -490,13 +490,13 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb
linearizeInstallPlan :: PackageIndex
-> InstallPlan
-> [(ConfiguredPackage, PackageStatus)]
-> [(ReadyPackage, PackageStatus)]
linearizeInstallPlan installedPkgIndex plan =
unfoldr next plan
where
next plan' = case InstallPlan.ready plan' of
[] -> Nothing
((pkg ,_):_) -> Just ((pkg, status), plan'')
(pkg:_) -> Just ((pkg, status), plan'')
where
pkgid = packageId pkg
status = packageStatus installedPkgIndex pkg
......@@ -517,7 +517,7 @@ extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _ = []
packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus
packageStatus :: PackageIndex -> ReadyPackage -> PackageStatus
packageStatus installedPkgIndex cpkg =
case PackageIndex.lookupPackageName installedPkgIndex
(packageName cpkg) of
......@@ -531,7 +531,7 @@ packageStatus installedPkgIndex cpkg =
where
changes :: Installed.InstalledPackageInfo
-> ConfiguredPackage
-> ReadyPackage
-> [MergeResult PackageIdentifier PackageIdentifier]
changes pkg pkg' =
filter changed
......@@ -550,7 +550,7 @@ packageStatus installedPkgIndex cpkg =
printPlan :: Bool -- is dry run
-> Verbosity
-> [(ConfiguredPackage, PackageStatus)]
-> [(ReadyPackage, PackageStatus)]
-> SourcePackageDb
-> IO ()
printPlan dryRun verbosity plan sourcePkgDb = case plan of
......@@ -581,7 +581,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
[] -> ""
diff -> " changes: " ++ intercalate ", " (map change diff)
showLatest :: ConfiguredPackage -> String
showLatest :: ReadyPackage -> String
showLatest pkg = case mLatestVersion of
Just latestVersion ->
if pkgVersion < latestVersion
......@@ -600,15 +600,15 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
toFlagAssignment :: [Flag] -> FlagAssignment
toFlagAssignment = map (\ f -> (flagName f, flagDefault f))
nonDefaultFlags :: ConfiguredPackage -> FlagAssignment
nonDefaultFlags (ConfiguredPackage spkg fa _ _) =
nonDefaultFlags :: ReadyPackage -> FlagAssignment
nonDefaultFlags (ReadyPackage spkg fa _ _) =
let defaultAssignment =
toFlagAssignment
(genPackageFlags (Source.packageDescription spkg))
in fa \\ defaultAssignment
stanzas :: ConfiguredPackage -> [OptionalStanza]
stanzas (ConfiguredPackage _ _ sts _) = sts
stanzas :: ReadyPackage -> [OptionalStanza]
stanzas (ReadyPackage _ _ sts _) = sts
showStanzas :: [OptionalStanza] -> String
showStanzas = concatMap ((' ' :) . showStanza)
......@@ -848,7 +848,7 @@ updateSandboxTimestampsFile (UseSandbox sandboxDir)
withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do
let allInstalled = [ pkg | InstallPlan.Installed pkg _
<- InstallPlan.toList installPlan ]
allSrcPkgs = [ pkg | ConfiguredPackage pkg _ _ _ <- allInstalled ]
allSrcPkgs = [ pkg | ReadyPackage pkg _ _ _ <- allInstalled ]
allPaths = [ pth | LocalUnpackedPackage pth
<- map packageSource allSrcPkgs]
allPathsCanonical <- mapM tryCanonicalizePath allPaths
......@@ -892,9 +892,9 @@ performInstallations verbosity
installLock <- newLock -- serialise installation
cacheLock <- newLock -- serialise access to setup exe cache
executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg deps ->
installConfiguredPackage platform compid configFlags
cpkg deps $ \configFlags' src pkg pkgoverride ->
executeInstallPlan verbosity jobControl useLogFile installPlan $ \rpkg ->
installReadyPackage platform compid configFlags
rpkg $ \configFlags' src pkg pkgoverride ->
fetchSourcePackage verbosity fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit
(packageId pkg) src' distPref $ \mpath ->
......@@ -997,8 +997,7 @@ executeInstallPlan :: Verbosity
-> JobControl IO (PackageId, BuildResult)
-> UseLogFile
-> InstallPlan
-> (ConfiguredPackage -> [Installed.InstalledPackageInfo]
-> IO BuildResult)
-> (ReadyPackage -> IO BuildResult)
-> IO InstallPlan
executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
tryNewTasks 0 plan0
......@@ -1011,13 +1010,13 @@ executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
sequence_
[ do info verbosity $ "Ready to install " ++ display pkgid
spawnJob jobCtl $ do
buildResult <- installPkg pkg deps
buildResult <- installPkg pkg
return (packageId pkg, buildResult)
| (pkg, deps) <- pkgs
| pkg <- pkgs
, let pkgid = packageId pkg]
let taskCount' = taskCount + length pkgs
plan' = InstallPlan.processing (map fst pkgs) plan
plan' = InstallPlan.processing pkgs plan
waitForTasks taskCount' plan'
waitForTasks taskCount plan = do
......@@ -1066,22 +1065,23 @@ executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
mapM_ putStrLn (drop toDrop lns)
-- | Call an installer for an 'SourcePackage' but override the configure
-- flags with the ones given by the 'ConfiguredPackage'. In particular the
-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly
-- flags with the ones given by the 'ReadyPackage'. In particular the
-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly
-- versioned package dependencies. So we ignore any previous partial flag
-- assignment or dependency constraints and use the new ones.
--
installConfiguredPackage :: Platform -> CompilerId
-> ConfigFlags
-> ConfiguredPackage
-> [Installed.InstalledPackageInfo]
-> (ConfigFlags -> PackageLocation (Maybe FilePath)
-> PackageDescription
-> PackageDescriptionOverride -> a)
-> a
installConfiguredPackage platform comp configFlags
(ConfiguredPackage (SourcePackage _ gpkg source pkgoverride)
flags stanzas _) deps
-- NB: when updating this function, don't forget to also update
-- 'configurePackage' in D.C.Configure.
installReadyPackage :: Platform -> CompilerId
-> ConfigFlags
-> ReadyPackage
-> (ConfigFlags -> PackageLocation (Maybe FilePath)
-> PackageDescription
-> PackageDescriptionOverride -> a)
-> a
installReadyPackage platform comp configFlags
(ReadyPackage (SourcePackage _ gpkg source pkgoverride)
flags stanzas deps)
installPkg = installPkg configFlags {
configConfigurationsFlags = flags,
-- We generate the legacy constraints as well as the new style precise deps.
......@@ -1099,7 +1099,7 @@ installConfiguredPackage platform comp configFlags
pkg = case finalizePackageDescription flags
(const True)
platform comp [] (enableStanzas stanzas gpkg) of
Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
Left _ -> error "finalizePackageDescription ReadyPackage failed"
Right (desc, _) -> desc
fetchSourcePackage
......
......@@ -47,8 +47,9 @@ module Distribution.Client.InstallPlan (
import Distribution.Client.Types
( SourcePackage(packageDescription), ConfiguredPackage(..)
, InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas,
InstalledPackage (..) )
, ReadyPackage(..), readyPackageToConfiguredPackage
, InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas
, InstalledPackage (..) )
import Distribution.Package
( PackageIdentifier(..), PackageName(..), Package(..), packageName
, PackageFixedDeps(..), Dependency(..) )
......@@ -129,9 +130,11 @@ import Control.Exception
data PlanPackage = PreExisting InstalledPackage
| Configured ConfiguredPackage
| Processing ConfiguredPackage
| Installed ConfiguredPackage BuildSuccess
| Processing ReadyPackage
| Installed ReadyPackage BuildSuccess
| Failed ConfiguredPackage BuildFailure
-- ^ NB: packages in the Failed state can be *either* Ready
-- or Configured.
instance Package PlanPackage where
packageId (PreExisting pkg) = packageId pkg
......@@ -206,7 +209,7 @@ remove shouldRemove plan =
-- configured state and have all their dependencies installed already.
-- The plan is complete if the result is @[]@.
--
ready :: InstallPlan -> [(ConfiguredPackage, [Installed.InstalledPackageInfo])]
ready :: InstallPlan -> [ReadyPackage]
ready plan = assert check readyPackages
where
check = if null readyPackages && null processingPackages
......@@ -215,10 +218,10 @@ ready plan = assert check readyPackages
configuredPackages = [ pkg | Configured pkg <- toList plan ]
processingPackages = [ pkg | Processing pkg <- toList plan]
readyPackages :: [(ConfiguredPackage, [Installed.InstalledPackageInfo])]
readyPackages :: [ReadyPackage]
readyPackages =
[ (pkg, deps)
| pkg <- configuredPackages
[ ReadyPackage srcPkg flags stanzas deps
| pkg@(ConfiguredPackage srcPkg flags stanzas _) <- configuredPackages
-- select only the package that have all of their deps installed:
, deps <- maybeToList (hasAllInstalledDeps pkg)
]
......@@ -244,7 +247,7 @@ ready plan = assert check readyPackages
--
-- * The package must exist in the graph and be in the configured state.
--
processing :: [ConfiguredPackage] -> InstallPlan -> InstallPlan
processing :: [ReadyPackage] -> InstallPlan -> InstallPlan
processing pkgs plan = assert (invariant plan') plan'
where
plan' = plan {
......@@ -286,7 +289,7 @@ failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'
}
pkg = lookupProcessingPackage plan pkgid
failures = PackageIndex.fromList
$ Failed pkg buildResult
$ Failed (readyPackageToConfiguredPackage pkg) buildResult
: [ Failed pkg' buildResult'
| Just pkg' <- map checkConfiguredPackage
$ packagesThatDependOn plan pkgid ]
......@@ -303,7 +306,7 @@ packagesThatDependOn plan = map (planPkgOf plan)
-- | Lookup a package that we expect to be in the processing state.
--
lookupProcessingPackage :: InstallPlan
-> PackageIdentifier -> ConfiguredPackage
-> PackageIdentifier -> ReadyPackage
lookupProcessingPackage plan pkgid =
case PackageIndex.lookupPackageId (planIndex plan) pkgid of
Just (Processing pkg) -> pkg
......
......@@ -35,7 +35,7 @@ symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
#else
import Distribution.Client.Types
( SourcePackage(..), ConfiguredPackage(..), enableStanzas )
( SourcePackage(..), ReadyPackage(..), enableStanzas )
import Distribution.Client.Setup
( InstallFlags(installSymlinkBinDir) )
import qualified Distribution.Client.InstallPlan as InstallPlan
......@@ -127,12 +127,12 @@ symlinkBinaries configFlags installFlags plan =
, exe <- PackageDescription.executables pkg
, PackageDescription.buildable (PackageDescription.buildInfo exe) ]
pkgDescription :: ConfiguredPackage -> PackageDescription
pkgDescription (ConfiguredPackage (SourcePackage _ pkg _ _) flags stanzas _) =
pkgDescription :: ReadyPackage -> PackageDescription
pkgDescription (ReadyPackage (SourcePackage _ pkg _ _) flags stanzas _) =
case finalizePackageDescription flags
(const True)
platform compilerId [] (enableStanzas stanzas pkg) of
Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
Left _ -> error "finalizePackageDescription ReadyPackage failed"
Right (desc, _) -> desc
-- This is sadly rather complicated. We're kind of re-doing part of the
......
......@@ -91,6 +91,27 @@ instance Package ConfiguredPackage where
instance PackageFixedDeps ConfiguredPackage where
depends (ConfiguredPackage _ _ _ deps) = deps
-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be
-- installed already, hence itself ready to be installed.
data ReadyPackage = ReadyPackage
SourcePackage -- see 'ConfiguredPackage'.
FlagAssignment --
[OptionalStanza] --
[InstalledPackageInfo] -- Installed dependencies.
deriving Show
instance Package ReadyPackage where
packageId (ReadyPackage pkg _ _ _) = packageId pkg
instance PackageFixedDeps ReadyPackage where
depends (ReadyPackage _ _ _ deps) = map packageId deps
-- | Sometimes we need to convert a 'ReadyPackage' back to a
-- 'ConfiguredPackage'. For example, a failed 'PlanPackage' can be *either*
-- Ready or Configured.
readyPackageToConfiguredPackage :: ReadyPackage -> ConfiguredPackage
readyPackageToConfiguredPackage (ReadyPackage srcpkg flags stanzas deps) =
ConfiguredPackage srcpkg flags stanzas (map packageId deps)
-- | A package description along with the location of the package sources.
--
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment