Skip to content

GitLab

Commit 44a2cedc authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Opinionated tweaking of the previous patch

parent 5e469780
Hide whitespace changes
Inline Side-by-side
cabal-install/Distribution/Client/Install.hs
View file @ 44a2cedc
......@@ -890,18 +890,12 @@ performInstallations verbosity
executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg deps ->
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg pkgoverride ->
cpkg deps $ \configFlags' src pkg pkgoverride ->
fetchSourcePackage verbosity fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->
let configFlags'' = configFlags' { configDependencies =
zip
(map packageName $
map Installed.sourcePackageId deps)
(map Installed.installedPackageId deps)
} in
installUnpackedPackage verbosity buildLimit installLock numJobs
(setupScriptOptions installedPkgIndex cacheLock)
miscOptions configFlags'' installFlags haddockFlags
miscOptions configFlags' installFlags haddockFlags
compid platform pkg pkgoverride mpath useLogFile
where
......@@ -1001,7 +995,8 @@ executeInstallPlan :: Verbosity
-> JobControl IO (PackageId, BuildResult)
-> UseLogFile
-> InstallPlan
-> (ConfiguredPackage -> [Installed.InstalledPackageInfo] -> IO BuildResult)
-> (ConfiguredPackage -> [Installed.InstalledPackageInfo]
-> IO BuildResult)
-> IO InstallPlan
executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
tryNewTasks 0 plan0
......@@ -1075,17 +1070,26 @@ executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
-- assignment or dependency constraints and use the new ones.
--
installConfiguredPackage :: Platform -> CompilerId
-> ConfigFlags -> ConfiguredPackage
-> ConfigFlags
-> ConfiguredPackage
-> [Installed.InstalledPackageInfo]
-> (ConfigFlags -> PackageLocation (Maybe FilePath)
-> PackageDescription
-> PackageDescriptionOverride -> a)
-> a
installConfiguredPackage platform comp configFlags
(ConfiguredPackage (SourcePackage _ gpkg source pkgoverride)
flags stanzas deps)
flags stanzas _) deps
installPkg = installPkg 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 ],
configBenchmarks = toFlag False,
configTests = toFlag (TestStanzas `elem` stanzas)
} source pkg pkgoverride
......
cabal-install/Distribution/Client/InstallPlan.hs
View file @ 44a2cedc
......@@ -79,7 +79,7 @@ import qualified Distribution.InstalledPackageInfo as Installed
import Data.List
( sort, sortBy )
import Data.Maybe
( fromMaybe )
( fromMaybe, maybeToList )
import qualified Data.Graph as Graph
import Data.Graph (Graph)
import Control.Exception
......@@ -209,41 +209,36 @@ remove shouldRemove plan =
ready :: InstallPlan -> [(ConfiguredPackage, [Installed.InstalledPackageInfo])]
ready plan = assert check readyPackages
where
check = if null (map fst readyPackages) && null processingPackages
check = if null readyPackages && null processingPackages
then null configuredPackages
else True
configuredPackages = [ pkg | Configured pkg <- toList plan ]
processingPackages = [ pkg | Processing pkg <- toList plan]
readyPackages :: [(ConfiguredPackage, [Installed.InstalledPackageInfo])]
readyPackages = [ (pkg, map getInstalledDeps deps)
| pkg <- configuredPackages
, let deps = depends pkg
, all isInstalled deps
]
getInstalledDeps :: PackageIdentifier -> Installed.InstalledPackageInfo
getInstalledDeps pkg =
case PackageIndex.lookupPackageId (planIndex plan) pkg of
Just (Configured _) -> internalError "guard failed"
Just (Processing _) -> internalError "guard failed"
Just (Failed _ _) -> internalError "guard failed"
Just (PreExisting (InstalledPackage instPkg _)) -> instPkg
Just (Installed _cfgPkg (BuildOk _ _ Nothing)) -> internalError "guard failed"
Just (Installed _cfgPkg (BuildOk _ _ (Just instPkg))) -> instPkg
Nothing -> internalError "guard failed"
isInstalled :: PackageIdentifier -> Bool
isInstalled pkg =
case PackageIndex.lookupPackageId (planIndex plan) pkg of
Just (Configured _) -> False
Just (Processing _) -> False
Just (Failed _ _) -> internalError depOnFailed
Just (PreExisting _) -> True
Just (Installed _ _) -> True
Nothing -> internalError incomplete
readyPackages =
[ (pkg, deps)
| pkg <- configuredPackages
-- select only the package that have all of their deps installed:
, deps <- maybeToList (hasAllInstalledDeps pkg)
]
hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo]
hasAllInstalledDeps = mapM isInstalledDep . depends
isInstalledDep :: PackageIdentifier -> Maybe Installed.InstalledPackageInfo
isInstalledDep pkgid =
case PackageIndex.lookupPackageId (planIndex plan) pkgid of
Just (Configured _) -> Nothing
Just (Processing _) -> Nothing
Just (Failed _ _) -> internalError depOnFailed
Just (PreExisting (InstalledPackage instPkg _)) -> Just instPkg
Just (Installed _ (BuildOk _ _ (Just instPkg))) -> Just instPkg
Just (Installed _ (BuildOk _ _ Nothing)) -> internalError depOnNonLib
Nothing -> internalError incomplete
incomplete = "install plan is not closed"
depOnFailed = "configured package depends on failed package"
depOnNonLib = "configured package depends on a non-library package"
-- | Marks packages in the graph as currently processing (e.g. building).
--
......
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