Commit 88a95a36 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Use the Platform type rather than passing around the OS and Arch separately

parent 2d1f9ce5
......@@ -35,7 +35,7 @@ import Distribution.Client.Config
( defaultLogsDir )
import Distribution.System
( OS, Arch )
( Platform(Platform) )
import Distribution.Compiler
( CompilerId )
import Distribution.Simple.Utils
......@@ -94,24 +94,23 @@ storeLocal reports = do
fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]
fromInstallPlan plan = catMaybes
. map (fromPlanPackage os' arch' comp)
. map (fromPlanPackage platform comp)
. InstallPlan.toList
$ plan
where os' = InstallPlan.planOS plan
arch' = InstallPlan.planArch plan
comp = InstallPlan.planCompiler plan
where platform = InstallPlan.planPlatform plan
comp = InstallPlan.planCompiler plan
fromPlanPackage :: OS -> Arch -> CompilerId
fromPlanPackage :: Platform -> CompilerId
-> InstallPlan.PlanPackage
-> Maybe (BuildReport, Repo)
fromPlanPackage os' arch' comp planPackage = case planPackage of
fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
packageSource = RepoTarballPackage repo }) _ _) result
-> Just $ (BuildReport.new os' arch' comp pkg (Right result), repo)
-> Just $ (BuildReport.new os arch comp pkg (Right result), repo)
InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
packageSource = RepoTarballPackage repo }) _ _) result
-> Just $ (BuildReport.new os' arch' comp pkg (Left result), repo)
-> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
_ -> Nothing
......@@ -45,7 +45,7 @@ import Distribution.Version
import Distribution.Compiler
( CompilerId(..) )
import Distribution.System
( OS, Arch )
( Platform )
import Distribution.Simple.Utils (comparing)
import Distribution.Client.Utils (mergeBy, MergeResult(..))
......@@ -105,31 +105,29 @@ data PackagesInstalledPreference =
--
| PreferLatestForSelected
resolveDependencies :: OS
-> Arch
resolveDependencies :: Platform
-> CompilerId
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> PackagesPreference
-> [UnresolvedDependency]
-> Either String InstallPlan
resolveDependencies os arch comp installed available pref deps =
resolveDependencies platform comp installed available pref deps =
foldProgress (flip const) Left Right $
resolveDependenciesWithProgress os arch comp installed available pref deps
resolveDependenciesWithProgress platform comp installed available pref deps
resolveDependenciesWithProgress :: OS
-> Arch
resolveDependenciesWithProgress :: Platform
-> CompilerId
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> PackagesPreference
-> [UnresolvedDependency]
-> Progress String String InstallPlan
resolveDependenciesWithProgress os arch comp (Just installed) =
dependencyResolver defaultResolver os arch comp installed
resolveDependenciesWithProgress platform comp (Just installed) =
dependencyResolver defaultResolver platform comp installed
resolveDependenciesWithProgress os arch comp Nothing =
dependencyResolver bogusResolver os arch comp mempty
resolveDependenciesWithProgress platform comp Nothing =
dependencyResolver bogusResolver platform comp mempty
hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p
hideBrokenPackages index =
......@@ -150,13 +148,13 @@ basePackage = PackageName "base"
dependencyResolver
:: DependencyResolver
-> OS -> Arch -> CompilerId
-> Platform -> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> PackagesPreference
-> [UnresolvedDependency]
-> Progress String String InstallPlan
dependencyResolver resolver os arch comp installed available pref deps =
dependencyResolver resolver platform comp installed available pref deps =
let installed' = hideBrokenPackages installed
-- If the user is not explicitly asking to upgrade base then lets
-- prevent that from happening accidentally since it is usually not what
......@@ -169,11 +167,11 @@ dependencyResolver resolver os arch comp installed available pref deps =
pkg == basePackage
in fmap toPlan
$ resolver os arch comp installed' available' preference deps
$ resolver platform comp installed' available' preference deps
where
toPlan pkgs =
case InstallPlan.new os arch comp (PackageIndex.fromList pkgs) of
case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of
Right plan -> plan
Left problems -> error $ unlines $
"internal error: could not construct a valid install plan."
......
......@@ -36,6 +36,8 @@ import Distribution.Simple.Utils
( equating, comparing )
import Distribution.Text
( display )
import Distribution.System
( Platform(Platform) )
import Data.List
( maximumBy, sortBy, groupBy )
......@@ -46,7 +48,7 @@ import Data.List
-- We just pretend that everything is installed and hope for the best.
--
bogusResolver :: DependencyResolver
bogusResolver os arch comp _ available _ = resolveFromAvailable []
bogusResolver (Platform arch os) comp _ available _ = resolveFromAvailable []
. combineDependencies
where
resolveFromAvailable chosen [] = Done chosen
......
......@@ -46,7 +46,7 @@ import Distribution.Version
import Distribution.Compiler
( CompilerId )
import Distribution.System
( OS, Arch )
( Platform(Platform) )
import Distribution.Simple.Utils
( equating, comparing )
import Distribution.Text
......@@ -224,26 +224,26 @@ search configure pref constraints =
-- the standard 'DependencyResolver' interface.
--
topDownResolver :: DependencyResolver
topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'
topDownResolver = (((((mapMessages .).).).).) . topDownResolver'
where
mapMessages :: Progress Log Failure a -> Progress String String a
mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
-- | The native resolver with detailed structured logging and failure types.
--
topDownResolver' :: OS -> Arch -> CompilerId
topDownResolver' :: Platform -> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> (PackageName -> PackagePreference)
-> [UnresolvedDependency]
-> Progress Log Failure [PlanPackage]
topDownResolver' os arch comp installed available pref deps =
topDownResolver' platform comp installed available pref deps =
fmap (uncurry finalise)
. (\cs -> search configure pref cs initialPkgNames)
=<< constrainTopLevelDeps deps constraints
where
configure = configurePackage os arch comp
configure = configurePackage platform comp
constraints = Constraints.empty
(annotateInstalledPackages topSortNumber installed')
(annotateAvailablePackages deps topSortNumber available')
......@@ -268,8 +268,8 @@ constrainTopLevelDeps (UnresolvedDependency dep _:deps) cs =
Unsatisfiable -> Fail (TopLevelDependencyUnsatisfiable dep)
ConflictsWith conflicts -> Fail (TopLevelDependencyConflict dep conflicts)
configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage
configurePackage os arch comp available spkg = case spkg of
configurePackage :: Platform -> CompilerId -> ConfigurePackage
configurePackage (Platform arch os) comp available spkg = case spkg of
InstalledOnly ipkg -> Right (InstalledOnly ipkg)
AvailableOnly apkg -> fmap AvailableOnly (configure apkg)
InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)
......
......@@ -37,7 +37,7 @@ import Distribution.Version
import Distribution.Compiler
( CompilerId )
import Distribution.System
( OS, Arch )
( Platform )
import Prelude hiding (fail)
......@@ -49,8 +49,7 @@ import Prelude hiding (fail)
-- solving the package dependency problem and we want to make it easy to swap
-- in alternatives.
--
type DependencyResolver = OS
-> Arch
type DependencyResolver = Platform
-> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
......
......@@ -48,7 +48,7 @@ import Distribution.Simple.Utils
( die, notice, info, debug, setupMessage
, copyFileVerbose, writeFileAtomic )
import Distribution.System
( buildOS, buildArch )
( buildPlatform )
import Distribution.Text
( display )
import Distribution.Verbosity
......@@ -163,7 +163,7 @@ fetch verbosity packageDB repos comp conf deps = do
[ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]
let progress = resolveDependenciesWithProgress
buildOS buildArch (compilerId comp)
buildPlatform (compilerId comp)
installed' available
(packagesPreference PreferLatestForSelected versionPref)
deps'
......
......@@ -99,7 +99,7 @@ import Distribution.Simple.Utils as Utils
import Distribution.Client.Utils
( inDir, mergeBy, MergeResult(..) )
import Distribution.System
( OS(Windows), buildOS, Arch, buildArch )
( Platform(Platform), buildPlatform, OS(Windows), buildOS )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
......@@ -179,12 +179,11 @@ installWithPlanner planner verbosity packageDB repos comp conf configFlags insta
unless dryRun $ do
logsDir <- defaultLogsDir
let os = InstallPlan.planOS installPlan
arch = InstallPlan.planArch installPlan
compid = InstallPlan.planCompiler installPlan
let platform = InstallPlan.planPlatform installPlan
compid = InstallPlan.planCompiler installPlan
installPlan' <-
executeInstallPlan installPlan $ \cpkg ->
installConfiguredPackage os arch compid configFlags
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg ->
installAvailablePackage verbosity (packageId pkg) src $ \mpath ->
installUnpackedPackage verbosity (setupScriptOptions installed)
......@@ -286,7 +285,7 @@ planLocalPackage verbosity comp configFlags installed
depFlags = Cabal.configConfigurationsFlags configFlags
}
return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)
return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
installed' available'
(packagesPreference PreferLatestForSelected versionPrefs)
[localPkgDep]
......@@ -302,7 +301,7 @@ planRepoPackages installedPref comp installFlags deps installed
| Cabal.fromFlagOrDefault False (installReinstall installFlags)
= fmap (hideGivenDeps deps') installed
| otherwise = installed
return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)
return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
installed' available
(packagesPreference installedPref versionPrefs)
deps'
......@@ -314,7 +313,7 @@ planRepoPackages installedPref comp installFlags deps installed
planUpgradePackages :: Compiler -> Planner
planUpgradePackages comp (Just installed)
(AvailablePackageDb available versionPrefs) = return $
resolveDependenciesWithProgress buildOS buildArch (compilerId comp)
resolveDependenciesWithProgress buildPlatform (compilerId comp)
(Just installed) available
(packagesPreference PreferAllLatest versionPrefs)
[ UnresolvedDependency dep []
......@@ -443,12 +442,12 @@ executeInstallPlan plan installPkg = case InstallPlan.ready plan of
-- versioned package dependencies. So we ignore any previous partial flag
-- assignment or dependency constraints and use the new ones.
--
installConfiguredPackage :: OS -> Arch -> CompilerId
installConfiguredPackage :: Platform -> CompilerId
-> Cabal.ConfigFlags -> ConfiguredPackage
-> (Cabal.ConfigFlags -> AvailablePackageSource
-> PackageDescription -> a)
-> a
installConfiguredPackage os arch comp configFlags
installConfiguredPackage (Platform arch os) comp configFlags
(ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)
installPkg = installPkg configFlags {
Cabal.configConfigurationsFlags = flags,
......
......@@ -24,8 +24,7 @@ module Distribution.Client.InstallPlan (
failed,
-- ** Query functions
planOS,
planArch,
planPlatform,
planCompiler,
-- * Checking valididy of plans
......@@ -66,7 +65,7 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Text
( display )
import Distribution.System
( OS, Arch )
( Platform(Platform) )
import Distribution.Compiler
( CompilerId(..) )
import Distribution.Client.Utils
......@@ -148,32 +147,30 @@ data InstallPlan = InstallPlan {
planGraphRev :: Graph,
planPkgOf :: Graph.Vertex -> PlanPackage,
planVertexOf :: PackageIdentifier -> Graph.Vertex,
planOS :: OS,
planArch :: Arch,
planPlatform :: Platform,
planCompiler :: CompilerId
}
invariant :: InstallPlan -> Bool
invariant plan =
valid (planOS plan) (planArch plan) (planCompiler plan) (planIndex plan)
valid (planPlatform plan) (planCompiler plan) (planIndex plan)
internalError :: String -> a
internalError msg = error $ "InstallPlan: internal error: " ++ msg
-- | Build an installation plan from a valid set of resolved packages.
--
new :: OS -> Arch -> CompilerId -> PackageIndex PlanPackage
new :: Platform -> CompilerId -> PackageIndex PlanPackage
-> Either [PlanProblem] InstallPlan
new os arch compiler index =
case problems os arch compiler index of
new platform compiler index =
case problems platform compiler index of
[] -> Right InstallPlan {
planIndex = index,
planGraph = graph,
planGraphRev = Graph.transposeG graph,
planPkgOf = vertexToPkgId,
planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,
planOS = os,
planArch = arch,
planPlatform = platform,
planCompiler = compiler
}
where (graph, vertexToPkgId, pkgIdToVertex) =
......@@ -279,8 +276,8 @@ checkConfiguredPackage pkg =
--
-- * if the result is @False@ use 'problems' to get a detailed list.
--
valid :: OS -> Arch -> CompilerId -> PackageIndex PlanPackage -> Bool
valid os arch comp index = null (problems os arch comp index)
valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool
valid platform comp index = null (problems platform comp index)
data PlanProblem =
PackageInvalid ConfiguredPackage [PackageProblem]
......@@ -329,12 +326,12 @@ showPlanProblem (PackageStateInvalid pkg pkg') =
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
--
problems :: OS -> Arch -> CompilerId
problems :: Platform -> CompilerId
-> PackageIndex PlanPackage -> [PlanProblem]
problems os arch comp index =
problems platform comp index =
[ PackageInvalid pkg packageProblems
| Configured pkg <- PackageIndex.allPackages index
, let packageProblems = configuredPackageProblems os arch comp pkg
, let packageProblems = configuredPackageProblems platform comp pkg
, not (null packageProblems) ]
++ [ PackageMissingDeps pkg missingDeps
......@@ -416,9 +413,9 @@ stateDependencyRelation _ _ = False
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
--
configuredPackageValid :: OS -> Arch -> CompilerId -> ConfiguredPackage -> Bool
configuredPackageValid os arch comp pkg =
null (configuredPackageProblems os arch comp pkg)
configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool
configuredPackageValid platform comp pkg =
null (configuredPackageProblems platform comp pkg)
data PackageProblem = DuplicateFlag FlagName
| MissingFlag FlagName
......@@ -456,9 +453,9 @@ showPackageProblem (InvalidDep dep pkgid) =
++ " but the configuration specifies " ++ display pkgid
++ " which does not satisfy the dependency."
configuredPackageProblems :: OS -> Arch -> CompilerId
configuredPackageProblems :: Platform -> CompilerId
-> ConfiguredPackage -> [PackageProblem]
configuredPackageProblems os arch comp
configuredPackageProblems (Platform arch os) comp
(ConfiguredPackage pkg specifiedFlags specifiedDeps) =
[ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]
++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ]
......
......@@ -59,6 +59,8 @@ import Distribution.Simple.Setup
( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.System
( Platform(Platform) )
import System.Posix.Files
( getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink
......@@ -160,8 +162,7 @@ symlinkBinaries configFlags installFlags plan =
fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
os = InstallPlan.planOS plan
arch = InstallPlan.planArch plan
(Platform arch os) = InstallPlan.planPlatform plan
compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan
symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir
......
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